git.iko.soy/patch
on 32fc50f help sign in
b6af869
swap
0 ahead, 692 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
.stylish-haskell.yaml+3−2
@@ -149,5 +149,6 @@ columns: 110
149# needs to be aware of these, so it can parse the file correctly.
149# needs to be aware of these, so it can parse the file correctly.
150#
150#
151# No language extensions are enabled by default.
151# No language extensions are enabled by default.
152−language_extensions:
152+# language_extensions:
153− - TemplateHaskell
153+ # - TemplateHaskell
154+ # - QuasiQuotes
.travis.ymlnew file+15
@@ -0,0 +1,15 @@
1+# Cache Buster: 0
2+language: nix
3+cache:
4+ directories:
5+ - /nix
6+matrix:
7+ include:
8+ - env: COMPILER=ghc7103
9+ - env: COMPILER=ghc801
10+ - env: COMPILER=ghcjs
11+script:
12+ - set -e
13+ - nix-build -E "with (import <nixpkgs> {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }"
14+ - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed
15+
CONTRIBUTING.mddeleted−66
@@ -1,66 +0,0 @@
1−# Contribution Guide
2−
3−Contributions and issue reports are encouraged and appreciated!
4−
5−- [Opening Issues](#opening-issues)
6−- [Submitting Changes](#submitting-changes)
7− - [Guidelines for Commit Messages](#guidelines-for-commit-messages)
8− - [Guidelines for Pull Requests](#guidelines-for-pull-requests)
9− - [Code Quality](#code-quality)
10− - [Documentation](#documentation)
11−
12−## Opening Issues
13−
14−Before opening an issue, please check whether your issue has already been reported. Assuming it has not:
15−
16−* Describe the issue you're encountering or the suggestion you're making
17−* Include any relevant steps to reproduce or code samples you can. It's always easier for us to debug if we have something that demonstrates the error.
18−* Let us know what version of 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+183
@@ -0,0 +1,183 @@
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+
17+Since MonadHold depends on MonadSample, any [S] function also runs in [H] context.
18+
19+## Functions producing Event
20+
21+```haskell
22+-- Trivial Event
23+[ ] never :: Event a
24+
25+-- Extract Event from Dynamic
26+[ ] updated :: Dynamic a -> Event a
27+
28+-- Transform Event to Event using function
29+[ ] fmap :: (a -> b) -> Event a -> Event b
30+[ ] fmapMaybe :: (a -> Maybe b) -> Event a -> Event b
31+[ ] ffilter :: (a -> Bool) -> Event a -> Event a
32+[ ] ffor :: Event a -> (a -> b) -> Event b
33+[ ] fforMaybe :: Event a -> (a -> Maybe b) -> Event b
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+
50+-- Combine multiple Events
51+[ ] <> :: Semigroup a => Event a -> Event a -> Event a
52+[ ] difference :: Event a -> Event b -> Event a
53+[ ] align :: Event a -> Event b -> Event (These a b)
54+[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c
55+[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
56+[ ] leftmost :: [Event a] -> Event a
57+[ ] mergeList :: [Event a] -> Event (NonEmpty a)
58+[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)
59+[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)
60+
61+-- Efficient one-to-many fanout
62+[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)
63+[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k
64+[ ] select :: EventSelector k -> k a -> Event a
65+[ ] fanEither :: Event (Either a b) -> (Event a, Event b)
66+[ ] fanThese :: Event (These a b) -> (Event a, Event b)
67+
68+-- Event to Event via function that can sample current values
69+[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b
70+[ ] pushAlways :: (a -> m b ) -> Event a -> Event b
71+ -- Note supplied function operates in [H] context
72+
73+-- Split Event into next occurrence and all other future occurrences, as of now.
74+[H] headE :: Event a -> m (Event a)
75+[H] tailE :: Event a -> m (Event a)
76+[H] headTailE :: Event a -> m (Event a, Event a)
77+```
78+
79+## Functions producing Behavior
80+
81+```haskell
82+-- Trivial Behavior
83+[ ] constant :: a -> Behavior a
84+
85+-- Extract Behavior from Dynamic
86+[ ] current :: Dynamic a -> Behavior a
87+
88+-- Create Behavior with given initial value, updated when the Event fires.
89+[H] hold :: a -> Event a -> m (Behavior a)
90+
91+-- Transform Behavior to Behavior using function
92+[ ] fmap :: (a -> b) -> Behavior a -> Behavior b
93+[ ] ffor :: Behavior a -> (a -> b) -> Behavior b
94+[ ] <*> :: Behavior (a -> b) -> Behavior a -> Behavior b
95+[ ] >>= :: Behavior a -> (a -> Behavior b) -> Behavior b
96+[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a
97+-- ... plus many more due to typeclass membership
98+
99+-- Behavior to Behavior by sampling current values
100+[S] sample :: Behavior a -> m a
101+[ ] pull :: m a -> Behavior a
102+ -- Note supplied value is in [S] context
103+```
104+
105+## Functions producing Dynamic
106+
107+```haskell
108+-- Trivial Dynamic
109+[ ] constDyn :: a -> Dynamic a
110+
111+-- Create Dynamic with given initial value, updated (various ways) when the Event fires.
112+[H] holdDyn :: a -> Event a -> m (Dynamic a)
113+[H] foldDyn :: (a -> b -> b ) -> b -> Event a -> m (Dynamic b)
114+[H] foldDynMaybe :: (a -> b -> Maybe b ) -> b -> Event a -> m (Dynamic b)
115+[H] foldDynM :: (a -> b -> m' b ) -> b -> Event a -> m (Dynamic b)
116+[H] foldDynMaybeM :: (a -> b -> m' (Maybe b)) -> b -> Event a -> m (Dynamic b)
117+ -- Note m' supplies [H] context
118+
119+-- Initial value is 0; counts Event firings from now.
120+[H] count :: Num b => Event a -> m (Dynamic b)
121+-- Initial Bool value is supplied; toggles at each Event firing.
122+[H] toggle :: Bool -> Event a -> m (Dynamic Bool)
123+
124+-- Transform Dynamic to Dynamic using function
125+[ ] ffor :: Dynamic a -> (a -> b) -> Dynamic b
126+[ ] fmap :: (a -> b) -> Dynamic a -> Dynamic b
127+[ ] splitDynPure :: Dynamic (a, b) -> (Dynamic a, Dynamic b)
128+
129+-- Combine multiple Dynamics
130+[ ] mconcat :: Monoid a => [Dynamic a] -> Dynamic a
131+[ ] distributeDMapOverDynPure :: GCompare k => DMap (WrapArg Dynamic k) -> Dynamic (DMap k)
132+[ ] <*> :: Dynamic (a -> b) -> Dynamic a -> Dynamic b
133+[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b
134+[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c
135+
136+-- Efficient one-to-many fanout
137+[ ] demux :: Ord k => Dynamic k -> Demux k
138+[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool
139+
140+-- Dynamic to Dynamic, removing updates w/o value change
141+[ ] uniqDyn :: Eq a => Dynamic a -> Dynamic a
142+
143+-- Dynamic to identical Dynamic with debug trace. (Only prints if Dynamic is ultimately used.)
144+[ ] traceDyn :: Show a => String -> Dynamic a -> Dynamic a
145+[ ] traceDynWith :: (a -> String) -> Dynamic a -> Dynamic a
146+```
147+
148+## Flattening functions
149+
150+These functions flatten nested types such as Event-of-Event, Behavior-of-Event, Event-of-Behavior etc, removing the outer wrapper.
151+
152+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.
153+
154+```haskell
155+-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.
156+[ ] switch :: Behavior (Event a) -> Event a
157+
158+-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.
159+[ ] switchPromptlyDyn :: Dynamic (Event a) -> Event a
160+
161+-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.
162+[ ] coincidence :: Event (Event a) -> Event a
163+
164+-- Flatten Behavior-of-Behavior to Behavior. Behavior is an instance of Monad,
165+-- so the 'join' function from 'Control.Monad' suffices. The output of 'join' is
166+-- a Behavior whose value is equal to the current value of the current value of
167+-- the input.
168+[ ] join :: Behavior (Behavior a) -> Behavior a
169+
170+
171+-- Flatten Dynamic-of-Dynamic to Dynamic. New Dynamic is used immediately.
172+-- Output updated whenever inner OR outer Dynamic updates.
173+[ ] join :: Dynamic (Dynamic a) -> Dynamic a
174+[ ] joinDynThroughMap :: Ord k => Dynamic (Map k (Dynamic a)) -> Dynamic (Map k a)
175+
176+-- Analogous to 'hold': Create a Behavior that is initially identical to the
177+-- supplied Behavior. Updated to track a new Behavior whenever the Event fires.
178+[H] switcher :: Behavior a -> Event (Behavior a) -> m (Behavior a)
179+
180+-- Similar to above, for Events. Created Event initially tracks the first argument.
181+-- At switchover, the output Event immediately tracks the new Event.
182+[H] switchPromptly :: Event a -> Event (Event a) -> m (Event a)
183+```
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+34
@@ -0,0 +1,34 @@
1+{ mkDerivation, ghc, base, bifunctors, containers, deepseq
2+, dependent-map, dependent-sum, exception-transformers
3+, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
4+, monad-control, mtl, primitive, ref-tf, semigroupoids
5+, semigroups, split, stdenv, stm, syb, template-haskell
6+, these, transformers, transformers-compat, prim-uniq
7+, data-default, filepath, directory, filemanip
8+, useTemplateHaskell ? true
9+}:
10+mkDerivation {
11+ pname = "reflex";
12+ version = "0.5.0";
13+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
14+ libraryHaskellDepends = [
15+ base bifunctors containers dependent-map dependent-sum
16+ exception-transformers lens
17+ MemoTrie monad-control mtl primitive ref-tf semigroupoids
18+ semigroups stm syb template-haskell these transformers
19+ transformers-compat prim-uniq
20+ base bifunctors containers deepseq dependent-map dependent-sum
21+ mtl ref-tf split transformers data-default
22+ ] ++ (if !useTemplateHaskell then [] else [
23+ haskell-src-exts haskell-src-meta
24+ ]);
25+ testHaskellDepends = if ghc.isGhcjs or false then [] else [
26+ hlint filepath directory filemanip
27+ ];
28+ configureFlags = if useTemplateHaskell then [] else [
29+ "-f-use-template-haskell"
30+ ];
31+ homepage = "https://github.com/reflex-frp/reflex";
32+ description = "Higher-order Functional Reactive Programming";
33+ license = stdenv.lib.licenses.bsd3;
34+}
dep/reflex-platform/default.nixdeleted−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+300
@@ -0,0 +1,300 @@
1+Name: reflex
2+Version: 0.5.0
3+Synopsis: Higher-order Functional Reactive Programming
4+Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
5+License: BSD3
6+License-file: LICENSE
7+Author: Ryan Trinkle
8+Maintainer: ryan.trinkle@gmail.com
9+Stability: Experimental
10+Category: FRP
11+Build-type: Simple
12+Cabal-version: >=1.9.2
13+homepage: https://github.com/reflex-frp/reflex
14+bug-reports: https://github.com/reflex-frp/reflex/issues
15+
16+flag specialize-to-spidertimeline-global
17+ description: Specialize all Reflex functions to the SpiderTimeline Global implementation. This may improve performance, but will disable all other implementations.
18+ default: False
19+ manual: True
20+
21+flag use-reflex-optimizer
22+ description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
23+ default: False
24+ manual: True
25+
26+flag use-template-haskell
27+ description: Use template haskell to generate lenses
28+ default: True
29+ manual: True
30+
31+flag expose-all-unfoldings
32+ description: Build the library with -fexpose-all-unfoldings which can help client code specialize better
33+ default: False
34+ manual: True
35+
36+flag debug-trace-events
37+ description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!
38+ default: False
39+ manual: True
40+
41+flag experimental-dependent-sum-instances
42+ description: Use experimental incoherent instances for certain forked dependent-sum typeclasses
43+ default: False
44+ manual: True
45+
46+library
47+ hs-source-dirs: src
48+ build-depends:
49+ MemoTrie == 0.6.*,
50+ base >= 4.7 && < 4.11,
51+ bifunctors >= 5.2 && < 5.5,
52+ comonad,
53+ containers == 0.5.*,
54+ data-default >= 0.5 && < 0.8,
55+ dependent-map >= 0.2.4 && < 0.3,
56+ exception-transformers == 0.4.*,
57+ lens >= 4.7 && < 5,
58+ monad-control >= 1.0.1 && < 1.1,
59+ mtl >= 2.1 && < 2.3,
60+ prim-uniq >= 0.1.0.1 && < 0.2,
61+ primitive >= 0.5 && < 0.7,
62+ ref-tf == 0.4.*,
63+ reflection == 2.1.*,
64+ semigroupoids >= 4.0 && < 6,
65+ semigroups >= 0.16 && < 0.19,
66+ stm == 2.4.*,
67+ structs == 0.1,
68+ syb >= 0.5 && < 0.7,
69+ these >= 0.4 && < 0.8,
70+ transformers >= 0.2,
71+ transformers-compat >= 0.3
72+
73+ exposed-modules:
74+ Data.AppendMap,
75+ Data.Functor.Misc,
76+ Data.WeakBag,
77+ Data.FastWeakBag,
78+ Data.FastMutableIntMap,
79+ Reflex,
80+ Reflex.Class,
81+ Reflex.EventWriter,
82+ Reflex.Dynamic,
83+ Reflex.Dynamic.Uniq,
84+ Reflex.DynamicWriter,
85+ Reflex.FastWeak,
86+ Reflex.FunctorMaybe,
87+ Reflex.Host.Class,
88+ Reflex.Patch,
89+ Reflex.Patch.Class,
90+ Reflex.Patch.DMap,
91+ Reflex.Patch.DMapWithMove,
92+ Reflex.Patch.Map,
93+ Reflex.Patch.MapWithMove,
94+ Reflex.TriggerEvent.Base,
95+ Reflex.TriggerEvent.Class,
96+ Reflex.PerformEvent.Base,
97+ Reflex.PerformEvent.Class,
98+ Reflex.PostBuild.Base,
99+ Reflex.PostBuild.Class,
100+ Reflex.Query.Base,
101+ Reflex.Query.Class,
102+ Reflex.Requester.Base,
103+ Reflex.Requester.Class,
104+ Reflex.Spider,
105+ Reflex.Spider.Internal
106+
107+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
108+ ghc-prof-options: -fprof-auto
109+
110+ if flag(specialize-to-spidertimeline-global)
111+ cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
112+ else
113+ exposed-modules: Reflex.Pure
114+
115+ if flag(debug-trace-events)
116+ cpp-options: -DDEBUG_TRACE_EVENTS
117+ build-depends: bytestring
118+
119+ if flag(use-reflex-optimizer)
120+ cpp-options: -DUSE_REFLEX_OPTIMIZER
121+ build-depends: ghc
122+ exposed-modules: Reflex.Optimizer
123+
124+ if flag(use-template-haskell)
125+ cpp-options: -DUSE_TEMPLATE_HASKELL
126+ build-depends:
127+ dependent-sum >= 0.3 && < 0.5,
128+ haskell-src-exts >= 1.16 && < 1.19,
129+ haskell-src-meta >= 0.6 && < 0.8,
130+ template-haskell >= 2.9 && < 2.12
131+ exposed-modules:
132+ Reflex.Dynamic.TH
133+ other-extensions: TemplateHaskell
134+ else
135+ build-depends:
136+ dependent-sum == 0.4.*
137+
138+ if flag(expose-all-unfoldings)
139+ ghc-options: -fexpose-all-unfoldings
140+
141+ if flag(experimental-dependent-sum-instances)
142+ ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES
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+ if flag(specialize-to-spidertimeline-global)
165+ buildable: False
166+
167+test-suite CrossImpl
168+ type: exitcode-stdio-1.0
169+ main-is: Reflex/Test/CrossImpl.hs
170+ hs-source-dirs: test
171+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test
172+ build-depends:
173+ base,
174+ containers,
175+ dependent-map,
176+ mtl,
177+ ref-tf,
178+ reflex
179+ if flag(specialize-to-spidertimeline-global)
180+ buildable: False
181+
182+test-suite hlint
183+ type: exitcode-stdio-1.0
184+ main-is: hlint.hs
185+ hs-source-dirs: test
186+ build-depends: base
187+ , directory
188+ , filepath
189+ , filemanip
190+ , hlint == 1.9.*
191+ if impl(ghcjs)
192+ buildable: False
193+ buildable: False
194+
195+test-suite EventWriterT
196+ type: exitcode-stdio-1.0
197+ main-is: EventWriterT.hs
198+ hs-source-dirs: test
199+ build-depends: base
200+ , dependent-sum
201+ , lens
202+ , these
203+ , transformers
204+ , reflex
205+ , ref-tf
206+
207+test-suite RequesterT
208+ type: exitcode-stdio-1.0
209+ main-is: RequesterT.hs
210+ hs-source-dirs: test
211+ build-depends: base
212+ , dependent-sum
213+ , dependent-map
214+ , lens
215+ , these
216+ , transformers
217+ , reflex
218+ , ref-tf
219+ buildable: False
220+
221+test-suite QueryT
222+ type: exitcode-stdio-1.0
223+ main-is: QueryT.hs
224+ hs-source-dirs: test
225+ build-depends: base
226+ , containers
227+ , dependent-sum
228+ , dependent-map
229+ , lens
230+ , these
231+ , transformers
232+ , reflex
233+ , ref-tf
234+
235+test-suite GC-Semantics
236+ type: exitcode-stdio-1.0
237+ main-is: GC.hs
238+ hs-source-dirs: test
239+ if flag(specialize-to-spidertimeline-global)
240+ buildable: False
241+ build-depends: base
242+ , dependent-sum
243+ , dependent-map
244+ , these
245+ , transformers
246+ , reflex
247+ , ref-tf
248+
249+test-suite rootCleanup
250+ type: exitcode-stdio-1.0
251+ main-is: rootCleanup.hs
252+ hs-source-dirs: test
253+ build-depends: base
254+ , reflex
255+
256+benchmark spider-bench
257+ type: exitcode-stdio-1.0
258+ hs-source-dirs: bench
259+ main-is: Main.hs
260+ ghc-options: -Wall -O2 -rtsopts
261+ build-depends:
262+ base,
263+ criterion == 1.1.*,
264+ deepseq >= 1.3 && < 1.5,
265+ dependent-map,
266+ dependent-sum,
267+ mtl,
268+ primitive,
269+ reflex,
270+ stm,
271+ transformers >= 0.3
272+
273+benchmark saulzar-bench
274+ type: exitcode-stdio-1.0
275+ hs-source-dirs: bench test
276+ c-sources: bench-cbits/checkCapability.c
277+ main-is: RunAll.hs
278+ ghc-options: -Wall -O2 -rtsopts -threaded
279+ ghc-prof-options: -fprof-auto
280+ build-depends:
281+ base,
282+ containers == 0.5.*,
283+ criterion == 1.1.*,
284+ deepseq >= 1.3 && < 1.5,
285+ dependent-map,
286+ dependent-sum,
287+ loch-th,
288+ mtl,
289+ primitive,
290+ process,
291+ ref-tf,
292+ reflex,
293+ split,
294+ stm,
295+ time,
296+ transformers >= 0.3
297+
298+source-repository head
299+ type: git
300+ 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+409
@@ -0,0 +1,409 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RoleAnnotations #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeFamilies #-}
12+-- | 'Data.Map' with a better 'Monoid' instance
13+--
14+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has
15+-- @mappend = unionWith mappend@ instead.
16+module Data.AppendMap where
17+
18+import Prelude hiding (map)
19+
20+import Control.Lens
21+import Data.Align
22+import Data.Coerce
23+import Data.Default
24+import Data.Map (Map)
25+import qualified Data.Map as Map
26+import Data.Semigroup
27+import Data.Set (Set)
28+import Data.Typeable
29+import GHC.Generics (Generic)
30+import Reflex (FunctorMaybe (..))
31+import Reflex.Patch (Additive, Group (..))
32+
33+newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }
34+ deriving (Eq, Ord, Show, Read, Typeable, Generic, Functor, Foldable, Traversable, Align)
35+
36+type instance (Index (AppendMap k m)) = k
37+type instance (IxValue (AppendMap k m)) = m
38+
39+instance Ord k => Ixed (AppendMap k m) where
40+ ix i = _Wrapped . ix i
41+
42+instance Ord k => At (AppendMap k m) where
43+ at i = _Wrapped . at i
44+
45+instance FunctorMaybe (AppendMap k) where
46+ fmapMaybe = mapMaybe
47+
48+-- | Deletes a key, returning 'Nothing' if the result is empty.
49+nonEmptyDelete :: Ord k => k -> AppendMap k a -> Maybe (AppendMap k a)
50+nonEmptyDelete k vs =
51+ let deleted = delete k vs
52+ in if Data.AppendMap.null deleted
53+ then Nothing
54+ else Just deleted
55+
56+mapMaybeNoNull :: (a -> Maybe b)
57+ -> AppendMap token a
58+ -> Maybe (AppendMap token b)
59+mapMaybeNoNull f as =
60+ let bs = fmapMaybe f as
61+ in if Data.AppendMap.null bs
62+ then Nothing
63+ else Just bs
64+
65+instance FunctorWithIndex k (AppendMap k) where
66+ imap f = AppendMap . imap f . _unAppendMap
67+ imapped = _Wrapped . imapped
68+
69+instance FoldableWithIndex k (AppendMap k) where
70+ ifolded = _Wrapped . ifolded
71+
72+instance TraversableWithIndex k (AppendMap k) where
73+ itraverse = itraverseOf itraversed
74+ itraversed = _Wrapped . itraversed
75+
76+instance (Ord k, Semigroup m) => Semigroup (AppendMap k m) where
77+ (AppendMap m0) <> (AppendMap m1) = AppendMap $ Map.unionWith (<>) m0 m1
78+
79+instance (Ord k, Semigroup m) => Monoid (AppendMap k m) where
80+ mempty = empty
81+ mappend = (<>)
82+
83+instance (Ord k, Group q) => Group (AppendMap k q) where
84+ negateG = map negateG
85+
86+instance (Ord k, Additive q) => Additive (AppendMap k q)
87+
88+(!) :: forall k a. Ord k => AppendMap k a -> k -> a
89+(!) = coerce ((Map.!) @k @a)
90+infixl 9 !
91+
92+(\\) :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
93+(\\) = coerce ((Map.\\) @k @a @b)
94+infixl 9 \\
95+
96+null :: forall k a. AppendMap k a -> Bool
97+null = coerce (Map.null @k @a)
98+
99+size :: forall k a. AppendMap k a -> Int
100+size = coerce (Map.size @k @a)
101+
102+member :: forall k a. Ord k => k -> AppendMap k a -> Bool
103+member = coerce (Map.member @k @a)
104+
105+notMember :: forall k a. Ord k => k -> AppendMap k a -> Bool
106+notMember = coerce (Map.notMember @k @a)
107+
108+lookup :: forall k a. Ord k => k -> AppendMap k a -> Maybe a
109+lookup = coerce (Map.lookup @k @a)
110+
111+findWithDefault :: forall k a. Ord k => a -> k -> AppendMap k a -> a
112+findWithDefault = coerce (Map.findWithDefault @k @a)
113+
114+lookupLT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
115+lookupLT = coerce (Map.lookupLT @k @a)
116+
117+lookupGT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
118+lookupGT = coerce (Map.lookupGT @k @a)
119+
120+lookupLE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
121+lookupLE = coerce (Map.lookupLE @k @a)
122+
123+lookupGE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
124+lookupGE = coerce (Map.lookupGE @k @a)
125+
126+empty :: forall k a. AppendMap k a
127+empty = coerce (Map.empty @k @a)
128+
129+singleton :: forall k a. k -> a -> AppendMap k a
130+singleton = coerce (Map.singleton @k @a)
131+
132+insert :: forall k a. Ord k => k -> a -> AppendMap k a -> AppendMap k a
133+insert = coerce (Map.insert @k @a)
134+
135+insertWith :: Ord k => (a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
136+insertWith f = coerce (Map.insertWith f)
137+
138+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
139+insertWithKey f = coerce (Map.insertWithKey f)
140+
141+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> (Maybe a, AppendMap k a)
142+insertLookupWithKey f = coerce (Map.insertLookupWithKey f)
143+
144+delete :: forall k a. Ord k => k -> AppendMap k a -> AppendMap k a
145+delete = coerce (Map.delete @k @a)
146+
147+adjust :: Ord k => (a -> a) -> k -> AppendMap k a -> AppendMap k a
148+adjust f = coerce (Map.adjust f)
149+
150+adjustWithKey :: Ord k => (k -> a -> a) -> k -> AppendMap k a -> AppendMap k a
151+adjustWithKey f = coerce (Map.adjustWithKey f)
152+
153+update :: Ord k => (a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
154+update f = coerce (Map.update f)
155+
156+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
157+updateWithKey f = coerce (Map.updateWithKey f)
158+
159+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> (Maybe a, AppendMap k a)
160+updateLookupWithKey f = coerce (Map.updateLookupWithKey f)
161+
162+alter :: Ord k => (Maybe a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
163+alter f = coerce (Map.alter f)
164+
165+unionWith :: Ord k => (a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
166+unionWith f = coerce (Map.unionWith f)
167+
168+unionWithKey :: Ord k => (k -> a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
169+unionWithKey f = coerce (Map.unionWithKey f)
170+
171+unionsWith :: Ord k => (a -> a -> a) -> [AppendMap k a] -> AppendMap k a
172+unionsWith f = coerce (Map.unionsWith f)
173+
174+difference :: Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
175+difference = (\\)
176+
177+differenceWith :: Ord k => (a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
178+differenceWith f = coerce (Map.differenceWith f)
179+
180+differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
181+differenceWithKey f = coerce (Map.differenceWithKey f)
182+
183+intersectionWith :: Ord k => (a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
184+intersectionWith f = coerce (Map.intersectionWith f)
185+
186+intersectionWithKey :: Ord k => (k -> a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
187+intersectionWithKey f = coerce (Map.intersectionWithKey f)
188+
189+mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (AppendMap k a -> AppendMap k c) -> (AppendMap k b -> AppendMap k c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
190+mergeWithKey f = coerce (Map.mergeWithKey f)
191+
192+map :: (a -> b) -> AppendMap k a -> AppendMap k b
193+map = fmap
194+
195+mapWithKey :: (k -> a -> b) -> AppendMap k a -> AppendMap k b
196+mapWithKey = imap
197+
198+traverseWithKey :: Applicative t => (k -> a -> t b) -> AppendMap k a -> t (AppendMap k b)
199+traverseWithKey = itraverse
200+
201+mapAccum :: (a -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
202+mapAccum f = coerce (Map.mapAccum f)
203+
204+mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
205+mapAccumWithKey f = coerce (Map.mapAccumWithKey f)
206+
207+mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
208+mapAccumRWithKey f = coerce (Map.mapAccumRWithKey f)
209+
210+mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
211+mapKeys = coerce (Map.mapKeys @k2 @k1 @a)
212+
213+mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
214+mapKeysWith f = coerce (Map.mapKeysWith f)
215+
216+mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
217+mapKeysMonotonic = coerce (Map.mapKeysMonotonic @k1 @k2 @a)
218+
219+foldr :: (a -> b -> b) -> b -> AppendMap k a -> b
220+foldr f = coerce (Map.foldr f)
221+
222+foldl :: (a -> b -> a) -> a -> AppendMap k b -> a
223+foldl f = coerce (Map.foldl f)
224+
225+foldrWithKey :: (k -> a -> b -> b) -> b -> AppendMap k a -> b
226+foldrWithKey f = coerce (Map.foldrWithKey f)
227+
228+foldlWithKey :: (a -> k -> b -> a) -> a -> AppendMap k b -> a
229+foldlWithKey f = coerce (Map.foldlWithKey f)
230+
231+foldMapWithKey :: Monoid m => (k -> a -> m) -> AppendMap k a -> m
232+foldMapWithKey f = coerce (Map.foldMapWithKey f)
233+
234+foldr' :: (a -> b -> b) -> b -> AppendMap k a -> b
235+foldr' f = coerce (Map.foldr' f)
236+
237+foldl' :: (a -> b -> a) -> a -> AppendMap k b -> a
238+foldl' f = coerce (Map.foldl' f)
239+
240+foldrWithKey' :: (k -> a -> b -> b) -> b -> AppendMap k a -> b
241+foldrWithKey' f = coerce (Map.foldrWithKey' f)
242+
243+foldlWithKey' :: (a -> k -> b -> a) -> a -> AppendMap k b -> a
244+foldlWithKey' f = coerce (Map.foldlWithKey' f)
245+
246+elems :: forall k a. AppendMap k a -> [a]
247+elems = coerce (Map.elems @k @a)
248+
249+keys :: forall k a. AppendMap k a -> [k]
250+keys = coerce (Map.keys @k @a)
251+
252+assocs :: forall k a. AppendMap k a -> [(k, a)]
253+assocs = coerce (Map.assocs @k @a)
254+
255+keysSet :: forall k a. AppendMap k a -> Set k
256+keysSet = coerce (Map.keysSet @k @a)
257+
258+fromSet :: (k -> a) -> Set k -> AppendMap k a
259+fromSet f = coerce (Map.fromSet f)
260+
261+toList :: forall k a. AppendMap k a -> [(k, a)]
262+toList = coerce (Map.toList @k @a)
263+
264+fromList :: forall k a. Ord k => [(k, a)] -> AppendMap k a
265+fromList = coerce (Map.fromList @k @a)
266+
267+fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
268+fromListWith f = coerce (Map.fromListWith f)
269+
270+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
271+fromListWithKey f = coerce (Map.fromListWithKey f)
272+
273+toAscList :: forall k a. AppendMap k a -> [(k, a)]
274+toAscList = coerce (Map.toAscList @k @a)
275+
276+toDescList :: forall k a. AppendMap k a -> [(k, a)]
277+toDescList = coerce (Map.toDescList @k @a)
278+
279+fromAscList :: forall k a. Eq k => [(k, a)] -> AppendMap k a
280+fromAscList = coerce (Map.fromAscList @k @a)
281+
282+fromAscListWith :: Eq k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
283+fromAscListWith f = coerce (Map.fromAscListWith f)
284+
285+fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
286+fromAscListWithKey f = coerce (Map.fromAscListWithKey f)
287+
288+fromDistinctAscList :: forall k a. [(k, a)] -> AppendMap k a
289+fromDistinctAscList = coerce (Map.fromDistinctAscList @k @a)
290+
291+filter :: (a -> Bool) -> AppendMap k a -> AppendMap k a
292+filter f = coerce (Map.filter f)
293+
294+filterWithKey :: (k -> a -> Bool) -> AppendMap k a -> AppendMap k a
295+filterWithKey f = coerce (Map.filterWithKey f)
296+
297+partition :: (a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
298+partition f = coerce (Map.partition f)
299+
300+partitionWithKey :: (k -> a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
301+partitionWithKey f = coerce (Map.partitionWithKey f)
302+
303+mapMaybe :: (a -> Maybe b) -> AppendMap k a -> AppendMap k b
304+mapMaybe f = coerce (Map.mapMaybe f)
305+
306+mapMaybeWithKey :: (k -> a -> Maybe b) -> AppendMap k a -> AppendMap k b
307+mapMaybeWithKey f = coerce (Map.mapMaybeWithKey f)
308+
309+mapEither :: (a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
310+mapEither f = coerce (Map.mapEither f)
311+
312+mapEitherWithKey :: (k -> a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
313+mapEitherWithKey f = coerce (Map.mapEitherWithKey f)
314+
315+split :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, AppendMap k a)
316+split = coerce (Map.split @k @a)
317+
318+splitLookup :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, Maybe a, AppendMap k a)
319+splitLookup = coerce (Map.splitLookup @k @a)
320+
321+splitRoot :: forall k a. AppendMap k a -> [AppendMap k a]
322+splitRoot = coerce (Map.splitRoot @k @a)
323+
324+isSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
325+isSubmapOf = coerce (Map.isSubmapOf @k @a)
326+
327+isSubmapOfBy :: Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
328+isSubmapOfBy f = coerce (Map.isSubmapOfBy f)
329+
330+isProperSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
331+isProperSubmapOf = coerce (Map.isProperSubmapOf @k @a)
332+
333+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
334+isProperSubmapOfBy f = coerce (Map.isProperSubmapOfBy f)
335+
336+lookupIndex :: forall k a. Ord k => k -> AppendMap k a -> Maybe Int
337+lookupIndex = coerce (Map.lookupIndex @k @a)
338+
339+findIndex :: forall k a. Ord k => k -> AppendMap k a -> Int
340+findIndex = coerce (Map.findIndex @k @a)
341+
342+elemAt :: forall k a. Int -> AppendMap k a -> (k, a)
343+elemAt = coerce (Map.elemAt @k @a)
344+
345+updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> AppendMap k a -> AppendMap k a
346+updateAt = coerce (Map.updateAt @k @a)
347+
348+deleteAt :: forall k a. Int -> AppendMap k a -> AppendMap k a
349+deleteAt = coerce (Map.deleteAt @k @a)
350+
351+findMin :: forall k a. AppendMap k a -> (k, a)
352+findMin = coerce (Map.findMin @k @a)
353+
354+findMax :: forall k a. AppendMap k a -> (k, a)
355+findMax = coerce (Map.findMax @k @a)
356+
357+deleteMin :: forall k a. AppendMap k a -> AppendMap k a
358+deleteMin = coerce (Map.deleteMin @k @ a)
359+
360+deleteMax :: forall k a. AppendMap k a -> AppendMap k a
361+deleteMax = coerce (Map.deleteMax @k @a)
362+
363+deleteFindMin :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
364+deleteFindMin = coerce (Map.deleteFindMin @k @a)
365+
366+deleteFindMax :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
367+deleteFindMax = coerce (Map.deleteFindMax @k @a)
368+
369+updateMin :: (a -> Maybe a) -> AppendMap k a -> AppendMap k a
370+updateMin f = coerce (Map.updateMin f)
371+
372+updateMax :: (a -> Maybe a) -> AppendMap k a -> AppendMap k a
373+updateMax f = coerce (Map.updateMax f)
374+
375+updateMinWithKey :: (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
376+updateMinWithKey f = coerce (Map.updateMinWithKey f)
377+
378+updateMaxWithKey :: (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
379+updateMaxWithKey f = coerce (Map.updateMaxWithKey f)
380+
381+minView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
382+minView = coerce (Map.minView @k @a)
383+
384+maxView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
385+maxView = coerce (Map.maxView @k @a)
386+
387+minViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
388+minViewWithKey = coerce (Map.minViewWithKey @k @a)
389+
390+maxViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
391+maxViewWithKey = coerce (Map.maxViewWithKey @k @a)
392+
393+showTree :: forall k a. (Show k, Show a) => AppendMap k a -> String
394+showTree = coerce (Map.showTree @k @a)
395+
396+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> AppendMap k a -> String
397+showTreeWith f = coerce (Map.showTreeWith f)
398+
399+valid :: forall k a. Ord k => AppendMap k a -> Bool
400+valid = coerce (Map.valid @k @a)
401+
402+instance Default (AppendMap k a) where
403+ def = empty
404+
405+instance AppendMap k' v' ~ t => Rewrapped (AppendMap k a) t
406+
407+instance Wrapped (AppendMap k a) where
408+ type Unwrapped (AppendMap k a) = Map k a
409+ _Wrapped' = iso (\(AppendMap m) -> m) AppendMap
src/Data/FastMutableIntMap.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE TypeFamilies #-}
6+module Data.FastMutableIntMap
7+ ( FastMutableIntMap
8+ , new
9+ , newEmpty
10+ , insert
11+ , isEmpty
12+ , getFrozenAndClear
13+ , size
14+ , applyPatch
15+ , PatchIntMap (..)
16+ , traverseIntMapPatchWithKey
17+ , lookup
18+ , forIntersectionWithImmutable_
19+ , for_
20+ , patchIntMapNewElements
21+ , patchIntMapNewElementsMap
22+ , getDeletions
23+ ) where
24+
25+--TODO: Pure JS version
26+--TODO: Fast copy to FastIntMap
27+--TODO: Fast patch type
28+
29+import Prelude hiding (lookup)
30+import Data.IORef
31+import Data.IntMap.Strict (IntMap)
32+import qualified Data.IntMap.Strict as IntMap
33+import Data.Maybe
34+import Reflex.Patch.Class
35+import Data.Foldable (traverse_)
36+import Control.Monad.IO.Class
37+
38+newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))
39+
40+new :: IntMap a -> IO (FastMutableIntMap a)
41+new m = FastMutableIntMap <$> newIORef m
42+
43+newEmpty :: IO (FastMutableIntMap a)
44+newEmpty = FastMutableIntMap <$> newIORef IntMap.empty
45+
46+insert :: FastMutableIntMap a -> Int -> a -> IO ()
47+insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v
48+
49+lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)
50+lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r
51+
52+forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()
53+forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do
54+ a <- liftIO $ readIORef r
55+ traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b
56+
57+for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()
58+for_ (FastMutableIntMap r) f = do
59+ a <- liftIO $ readIORef r
60+ traverse_ f a
61+
62+isEmpty :: FastMutableIntMap a -> IO Bool
63+isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r
64+
65+size :: FastMutableIntMap a -> IO Int
66+size (FastMutableIntMap r) = IntMap.size <$> readIORef r
67+
68+-- | Make an immutable snapshot of the datastructure and clear it
69+getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)
70+getFrozenAndClear (FastMutableIntMap r) = do
71+ result <- readIORef r
72+ writeIORef r IntMap.empty
73+ return result
74+
75+applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
76+applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
77+ v <- readIORef r
78+ writeIORef r $! applyAlways p v
79+ return $ IntMap.intersection v m
80+
81+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
82+
83+instance Patch (PatchIntMap a) where
84+ type PatchTarget (PatchIntMap a) = IntMap a
85+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
86+ let removes = IntMap.filter isNothing p
87+ adds = IntMap.mapMaybe id p
88+ in IntMap.union adds $ v `IntMap.difference` removes
89+
90+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)
91+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
92+
93+patchIntMapNewElements :: PatchIntMap a -> [a]
94+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
95+
96+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
97+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
98+
99+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
100+getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Data/FastWeakBag.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+#ifdef USE_REFLEX_OPTIMIZER
4+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
5+#endif
6+#ifdef ghcjs_HOST_OS
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_HOST_OS
25+ , _weakBag_children --TODO: Don't export this
26+#endif
27+ ) where
28+
29+import Control.Monad hiding (forM_, mapM_)
30+import Control.Monad.IO.Class
31+
32+#ifdef ghcjs_HOST_OS
33+import GHCJS.Types
34+import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)
35+#else
36+import Control.Exception
37+import Data.Foldable (forM_, mapM_)
38+import Data.IntMap.Strict (IntMap)
39+import qualified Data.IntMap.Strict as IntMap
40+import Data.IORef
41+import System.Mem.Weak
42+#endif
43+
44+import Prelude hiding (mapM_, traverse)
45+
46+-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -
47+-- that is, they can still be garbage-collected. As long as the @a@s remain
48+-- alive, the 'FastWeakBag' will continue to refer to them.
49+#ifdef ghcjs_HOST_OS
50+newtype FastWeakBag a = FastWeakBag JSVal
51+#else
52+data FastWeakBag a = FastWeakBag
53+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
54+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
55+ }
56+#endif
57+
58+-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If
59+-- the caller retains the ticket, the item is guranteed to stay in memory (and
60+-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from
61+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
62+#ifdef ghcjs_HOST_OS
63+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
64+#else
65+data FastWeakBagTicket a = FastWeakBagTicket
66+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
67+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
68+ }
69+#endif
70+
71+-- | Insert an item into a 'FastWeakBag'.
72+{-# INLINE insert #-}
73+insert :: a -- ^ The item
74+ -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
75+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
76+ -- is retained and allows the item to be removed.
77+#ifdef ghcjs_HOST_OS
78+insert a wb = js_insert (unsafeToRawJSVal a) wb
79+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
80+#else
81+insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
82+ a' <- evaluate a
83+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
84+ let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())
85+ wa <- mkWeakPtr a' $ Just cleanup
86+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
87+ return $ FastWeakBagTicket
88+ { _weakBagTicket_weakItem = wa
89+ , _weakBagTicket_item = a'
90+ }
91+#endif
92+
93+-- | Create an empty 'FastWeakBag'.
94+{-# INLINE empty #-}
95+empty :: IO (FastWeakBag a)
96+#ifdef ghcjs_HOST_OS
97+empty = js_empty
98+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
99+#else
100+empty = {-# SCC "empty" #-} do
101+ nextId <- newIORef 1
102+ children <- newIORef IntMap.empty
103+ let bag = FastWeakBag
104+ { _weakBag_nextId = nextId
105+ , _weakBag_children = children
106+ }
107+ return bag
108+#endif
109+
110+-- | Check whether a 'FastWeakBag' is empty.
111+{-# INLINE isEmpty #-}
112+isEmpty :: FastWeakBag a -> IO Bool
113+#ifdef ghcjs_HOST_OS
114+isEmpty = js_isEmpty
115+foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time
116+#else
117+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
118+#endif
119+
120+{-# INLINE traverse #-}
121+-- | Visit every node in the given list. If new nodes are appended during the
122+-- traversal, they will not be visited. Every live node that was in the list
123+-- when the traversal began will be visited exactly once; however, no guarantee
124+-- is made about the order of the traversal.
125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
126+#ifdef ghcjs_HOST_OS
127+traverse wb f = do
128+ let go cursor = when (not $ js_isNull cursor) $ do
129+ val <- liftIO $ js_getTicketValue cursor
130+ f $ unsafeFromRawJSVal val
131+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
132+ go =<< liftIO (js_getInitial wb)
133+foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
134+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
135+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag
136+foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
137+#else
138+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
139+ cs <- liftIO $ readIORef children
140+ forM_ cs $ \c -> do
141+ ma <- liftIO $ deRefWeak c
142+ mapM_ f ma
143+#endif
144+
145+-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
146+-- on the same 'FastWeakBagTicket'.
147+{-# INLINE remove #-}
148+remove :: FastWeakBagTicket a -> IO ()
149+#ifdef ghcjs_HOST_OS
150+remove = js_remove
151+foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here
152+#else
153+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w
154+#endif
155+--TODO: Should 'remove' also drop the reference to the item?
156+
157+--TODO: can/should we provide a null FastWeakBagTicket?
src/Data/Functor/Misc.hs+134−25
@@ -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'.
@@ -18,7 +23,6 @@ module Data.Functor.Misc
18 Const2 (..)
23 Const2 (..)
19 , unConst2
24 , unConst2
20 , dmapToMap
25 , dmapToMap
21− , dmapToIntMap
22 , dmapToMapWith
26 , dmapToMapWith
23 , mapToDMap
27 , mapToDMap
24 , weakenDMapWith
28 , weakenDMapWith
@@ -26,30 +30,34 @@ module Data.Functor.Misc
26 , WrapArg (..)
30 , WrapArg (..)
27 -- * Convenience functions for DMap
31 -- * Convenience functions for DMap
28 , mapWithFunctorToDMap
32 , mapWithFunctorToDMap
29− , intMapWithFunctorToDMap
30 , mapKeyValuePairsMonotonic
33 , mapKeyValuePairsMonotonic
31 , combineDMapsWithKey
34 , combineDMapsWithKey
32 , EitherTag (..)
35 , EitherTag (..)
33 , dmapToThese
36 , dmapToThese
34 , eitherToDSum
37 , eitherToDSum
35 , dsumToEither
38 , dsumToEither
39+ -- * Deprecated functions
40+ , sequenceDmap
41+ , wrapDMap
42+ , rewrapDMap
43+ , unwrapDMap
44+ , unwrapDMapMaybe
45+ , extractFunctorDMap
36 , ComposeMaybe (..)
46 , ComposeMaybe (..)
37 ) where
47 ) where
38
48
39−import Control.Applicative ((<$>))
49+import Control.Applicative (Applicative, (<$>))
50+import Control.Monad.Identity
40import Data.Dependent.Map (DMap)
51import Data.Dependent.Map (DMap)
41import qualified Data.Dependent.Map as DMap
52import qualified Data.Dependent.Map as DMap
42import Data.Dependent.Sum
53import Data.Dependent.Sum
43−import Data.Functor.Identity
44import Data.GADT.Compare
54import Data.GADT.Compare
45import Data.GADT.Show
55import Data.GADT.Show
46−import Data.IntMap (IntMap)
47−import qualified Data.IntMap as IntMap
48import Data.Map (Map)
56import Data.Map (Map)
49import qualified Data.Map as Map
57import qualified Data.Map as Map
50−import Data.Some (Some, mkSome)
58+import Data.Some (Some)
59+import qualified Data.Some as Some
51import Data.These
60import Data.These
52−import Data.Type.Equality ((:~:)(Refl))
53import Data.Typeable hiding (Refl)
61import Data.Typeable hiding (Refl)
54
62
55--------------------------------------------------------------------------------
63--------------------------------------------------------------------------------
@@ -62,7 +70,6 @@ data Const2 :: * -> x -> x -> * where
62 Const2 :: k -> Const2 k v v
70 Const2 :: k -> Const2 k v v
63 deriving (Typeable)
71 deriving (Typeable)
64
72
65−-- | Extract the value from a Const2
66unConst2 :: Const2 k v v' -> k
73unConst2 :: Const2 k v v' -> k
67unConst2 (Const2 k) = k
74unConst2 (Const2 k) = k
68
75
@@ -72,30 +79,53 @@ deriving instance Show k => Show (Const2 k v v')
72deriving instance Read k => Read (Const2 k v v)
79deriving instance Read k => Read (Const2 k v v)
73
80
74instance Show k => GShow (Const2 k v) where
81instance Show k => GShow (Const2 k v) where
82+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
83+ gshowToShow (Const2 _) = id
84+#else
75 gshowsPrec n x@(Const2 _) = showsPrec n x
85 gshowsPrec n x@(Const2 _) = showsPrec n x
86+#endif
87+
88+instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
89+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
90+ showTagToShow (Const2 _) _ = id
91+#else
92+ showTaggedPrec (Const2 _) = showsPrec
93+#endif
76
94
77instance Eq k => GEq (Const2 k v) where
95instance Eq k => GEq (Const2 k v) where
96+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
97+ geqToEq _ = id
98+ geqUnify (Const2 _) (Const2 _) _ = id
99+#else
78 geq (Const2 a) (Const2 b) =
100 geq (Const2 a) (Const2 b) =
79 if a == b
101 if a == b
80 then Just Refl
102 then Just Refl
81 else Nothing
103 else Nothing
104+#endif
82
105
83instance Ord k => GCompare (Const2 k v) where
106instance Ord k => GCompare (Const2 k v) where
107+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
108+ gcompareToOrd (Const2 _) = id
109+ gcompare (Const2 a) (Const2 b) = strengthenOrdering $ compare a b
110+#else
84 gcompare (Const2 a) (Const2 b) = case compare a b of
111 gcompare (Const2 a) (Const2 b) = case compare a b of
85 LT -> GLT
112 LT -> GLT
86 EQ -> GEQ
113 EQ -> GEQ
87 GT -> GGT
114 GT -> GGT
115+#endif
116+
117+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
118+instance {-# INCOHERENT #-} (Eq k, Eq v) => EqTag (Const2 k v) Identity where
119+ eqTagToEq (Const2 _) _ = id
120+
121+instance {-# INCOHERENT #-} Eq k => EqTag (Const2 k v) (Const2 k v) where
122+ eqTagToEq (Const2 _) _ = id
123+#endif
88
124
89-- | Convert a 'DMap' to a regular 'Map'
125-- | Convert a 'DMap' to a regular 'Map'
90dmapToMap :: DMap (Const2 k v) Identity -> Map k v
126dmapToMap :: DMap (Const2 k v) Identity -> Map k v
91dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
127dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
92
128
93−-- | Convert a 'DMap' to an 'IntMap'
94−dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
95−dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
96−
97−-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
98−-- the wrapping 'Functor'
99dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
129dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
100dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
130dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
101
131
@@ -108,15 +138,8 @@ mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v)
108mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
138mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
109mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
139mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
110
140
111−-- | Convert a regular 'IntMap', where the values are already wrapped in a
112−-- functor, to a 'DMap'
113−intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
114−intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
115−
116−-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
117−-- the keys, using a function to remove the wrapping 'Functor'
118weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
141weakenDMapWith :: (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
142+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList
120
143
121--------------------------------------------------------------------------------
144--------------------------------------------------------------------------------
122-- WrapArg
145-- WrapArg
@@ -134,9 +157,17 @@ deriving instance Show (f a) => Show (WrapArg g f (g' a))
134deriving instance Read (f a) => Read (WrapArg g f (g a))
157deriving instance Read (f a) => Read (WrapArg g f (g a))
135
158
136instance GEq f => GEq (WrapArg g f) where
159instance GEq f => GEq (WrapArg g f) where
160+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
161+ geqToEq (WrapArg f) = geqToEq f
162+ geqUnify (WrapArg a) (WrapArg b) = geqUnify a b
163+#else
137 geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
164 geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
165+#endif
138
166
139instance GCompare f => GCompare (WrapArg g f) where
167instance GCompare f => GCompare (WrapArg g f) where
168+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
169+ gcompareToOrd (WrapArg f) = gcompareToOrd f
170+#endif
140 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
171 gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
141 GLT -> GLT
172 GLT -> GLT
142 GEQ -> GEQ
173 GEQ -> GEQ
@@ -188,13 +219,34 @@ deriving instance Show (EitherTag l r a)
188deriving instance Eq (EitherTag l r a)
219deriving instance Eq (EitherTag l r a)
189deriving instance Ord (EitherTag l r a)
220deriving instance Ord (EitherTag l r a)
190
221
222+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
223+instance {-# INCOHERENT #-} (Show (f l), Show (f r)) => ShowTag (EitherTag l r) f where
224+ showTagToShow e _ = case e of
225+ LeftTag -> id
226+ RightTag -> id
227+
228+instance {-# INCOHERENT #-} (Eq (f l), Eq (f r)) => EqTag (EitherTag l r) f where
229+ eqTagToEq e _ = case e of
230+ LeftTag -> id
231+ RightTag -> id
232+#endif
233+
191instance GEq (EitherTag l r) where
234instance GEq (EitherTag l r) where
235+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
236+ geqToEq _ = id
237+ geqUnify LeftTag LeftTag _ same = same
238+ geqUnify RightTag RightTag _ same = same
239+ geqUnify _ _ unknown _ = unknown
240+#endif
192 geq a b = case (a, b) of
241 geq a b = case (a, b) of
193 (LeftTag, LeftTag) -> Just Refl
242 (LeftTag, LeftTag) -> Just Refl
194 (RightTag, RightTag) -> Just Refl
243 (RightTag, RightTag) -> Just Refl
195 _ -> Nothing
244 _ -> Nothing
196
245
197instance GCompare (EitherTag l r) where
246instance GCompare (EitherTag l r) where
247+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
248+ gcompareToOrd _ = id
249+#endif
198 gcompare a b = case (a, b) of
250 gcompare a b = case (a, b) of
199 (LeftTag, LeftTag) -> GEQ
251 (LeftTag, LeftTag) -> GEQ
200 (LeftTag, RightTag) -> GLT
252 (LeftTag, RightTag) -> GLT
@@ -202,9 +254,24 @@ instance GCompare (EitherTag l r) where
202 (RightTag, RightTag) -> GEQ
254 (RightTag, RightTag) -> GEQ
203
255
204instance GShow (EitherTag l r) where
256instance GShow (EitherTag l r) where
257+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
258+ gshowToShow _ = id
259+#else
205 gshowsPrec _ a = case a of
260 gshowsPrec _ a = case a of
206 LeftTag -> showString "LeftTag"
261 LeftTag -> showString "LeftTag"
207 RightTag -> showString "RightTag"
262 RightTag -> showString "RightTag"
263+#endif
264+
265+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
266+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
267+ showTagToShow t _ = case t of
268+ LeftTag -> id
269+ RightTag -> id
270+#else
271+ showTaggedPrec t n (Identity a) = case t of
272+ LeftTag -> showsPrec n a
273+ RightTag -> showsPrec n a
274+#endif
208
275
209-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
276-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
210eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
277eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
@@ -225,7 +292,49 @@ dsumToEither = \case
225-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
292-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
226-- make the 'f' parameter have a nominal type role. We need f to be
293-- make the 'f' parameter have a nominal type role. We need f to be
227-- representational so that we can use safe 'coerce'.
294-- representational so that we can use safe 'coerce'.
228−newtype ComposeMaybe f a =
229− ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
295+newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
230
296
231deriving instance Functor f => Functor (ComposeMaybe f)
297deriving instance Functor f => Functor (ComposeMaybe f)
298+
299+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
300+instance {-# INCOHERENT #-} EqTag f g => EqTag f (ComposeMaybe g) where
301+ eqTagToEq f _ = eqTagToEq f (Proxy :: Proxy g)
302+
303+instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where
304+ showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)
305+#endif
306+--------------------------------------------------------------------------------
307+-- Deprecated functions
308+--------------------------------------------------------------------------------
309+
310+{-# INLINE sequenceDmap #-}
311+{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}
312+-- | Run the actions contained in the 'DMap'
313+sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)
314+sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t
315+
316+{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}
317+-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor
318+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
319+wrapDMap f = DMap.map $ f . runIdentity
320+
321+{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}
322+-- | Replace one functor for a 'DMap''s values with a different functor
323+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
324+rewrapDMap = DMap.map
325+
326+{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}
327+-- | Replace one functor for a 'DMap''s values with the 'Identity' functor
328+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
329+unwrapDMap f = DMap.map $ Identity . f
330+
331+{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}
332+-- | Like 'unwrapDMap', but possibly delete some values from the DMap
333+unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
334+unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a
335+
336+{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}
337+-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the
338+-- underlying functor
339+extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
340+extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v
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/DMap.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE Rank2Types #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−{-# LANGUAGE TypeFamilies #-}
9−
10−-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
11−module Data.Patch.DMap where
12−
13−import Data.Patch.Class
14−import Data.Patch.IntMap
15−import Data.Patch.Map
16−
17−import Data.Dependent.Map (DMap)
18−import Data.Dependent.Sum (DSum (..))
19−import Data.GADT.Compare (GCompare (..))
20−import qualified Data.Dependent.Map as DMap
21−import Data.Functor.Constant
22−import Data.Functor.Misc
23−import qualified Data.IntMap as IntMap
24−import qualified Data.Map as Map
25−import Data.Monoid.DecidablyEmpty
26−#if !MIN_VERSION_base(4,11,0)
27−import Data.Semigroup (Semigroup (..))
28−#endif
29−import Data.Some (Some)
30−
31−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
32−-- Insertions are represented as @'ComposeMaybe' (Just value)@,
33−-- while deletions are represented as @'ComposeMaybe' Nothing@.
34−newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
35−
36−deriving instance GCompare k => Semigroup (PatchDMap k v)
37−
38−deriving instance GCompare k => Monoid (PatchDMap k v)
39−
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'.
45−instance GCompare k => Patch (PatchDMap k v) where
46− 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?
48− where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
49− deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
50− nothingToJust = \case
51− Nothing -> Just $ Constant ()
52− Just _ -> Nothing
53−
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'@.
56−mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
57−mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
58−
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')
62−traversePatchDMap f = traversePatchDMapWithKey $ const f
63−
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'@.
66−traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
67−traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
68−
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.
71−weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
72−weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
73−
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'
77−patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
78−
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'
81−const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
82− where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')
83− g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
84−
85−-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.
86−const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f
87−const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p
88− where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)
89− g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
90−
91−-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.
92−getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
93−getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
src/Data/Patch/IntMap.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE StandaloneDeriving #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−{-# LANGUAGE TypeFamilies #-}
9−
10−-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for
11−-- insert/update or delete of associations.
12−module Data.Patch.IntMap where
13−
14−import Control.Lens
15−import Data.IntMap.Strict (IntMap)
16−import qualified Data.IntMap.Strict as IntMap
17−import Data.Maybe
18−import Data.Monoid.DecidablyEmpty
19−#if !MIN_VERSION_base(4,11,0)
20−import Data.Semigroup (Semigroup (..))
21−#endif
22−import Data.Patch.Class
23−
24−-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
25−-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update
26−-- and @Nothing@ means delete.
27−newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }
28− deriving ( Show, Read, Eq, Ord
29− , Functor, Foldable, Traversable
30− , Monoid, DecidablyEmpty
31− )
32−
33−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
34−-- If the same key is modified by both patches, the one on the left will take
35−-- precedence.
36−deriving instance Semigroup (PatchIntMap v)
37−
38−makeWrapped ''PatchIntMap
39−
40−-- | Apply the insertions or deletions to a given 'IntMap'.
41−instance Patch (PatchIntMap a) where
42− type PatchTarget (PatchIntMap a) = IntMap a
43− apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
44− let removes = IntMap.filter isNothing p
45− adds = IntMap.mapMaybe id p
46− in IntMap.union adds $ v `IntMap.difference` removes
47−
48−instance FunctorWithIndex Int PatchIntMap
49−instance FoldableWithIndex Int PatchIntMap
50−instance TraversableWithIndex Int PatchIntMap where
51− itraverse = itraversed . Indexed
52− itraversed = _Wrapped .> itraversed <. traversed
53−
54−-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@
55−-- (that is, all inserts/updates), producing a @PatchIntMap b@.
56−mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b
57−mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m
58−
59−-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@
60−-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
61−traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
62−traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (traverse . f) m
63−
64−-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
65−patchIntMapNewElements :: PatchIntMap a -> [a]
66−patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
67−
68−-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all
69−-- the inserts/updates in the given patch.
70−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
71−patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
72−
73−-- | Subset the given @'IntMap' a@ to contain only the keys that would be
74−-- deleted by the given @'PatchIntMap' a@.
75−getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
76−getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Data/Patch/MapWithMove.hsdeleted−312
@@ -1,312 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PatternGuards #-}
9−{-# LANGUAGE PatternSynonyms #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE StandaloneDeriving #-}
12−{-# LANGUAGE TemplateHaskell #-}
13−{-# LANGUAGE TypeApplications #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE ViewPatterns #-}
16−
17−-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
18−-- another
19−module Data.Patch.MapWithMove
20− ( PatchMapWithMove
21− ( PatchMapWithMove
22− , unPatchMapWithMove
23− , ..
24− )
25− , patchMapWithMove
26− , patchMapWithMoveInsertAll
27− , insertMapKey
28− , moveMapKey
29− , swapMapKey
30− , deleteMapKey
31− , unsafePatchMapWithMove
32− , patchMapWithMoveNewElements
33− , patchMapWithMoveNewElementsMap
34− , patchThatSortsMapWith
35− , patchThatChangesAndSortsMapWith
36− , patchThatChangesMap
37−
38− -- * Node Info
39− , NodeInfo
40− ( NodeInfo
41− , _nodeInfo_to
42− , _nodeInfo_from
43− , ..
44− )
45− , bitraverseNodeInfo
46− , nodeInfoMapFrom
47− , nodeInfoMapMFrom
48− , nodeInfoSetTo
49−
50− -- * From
51− , From
52− ( From_Insert
53− , From_Delete
54− , From_Move
55− , ..
56− )
57− , bitraverseFrom
58−
59− -- * To
60− , To
61− ) where
62−
63−import Data.Coerce
64−import Data.Kind (Type)
65−import Data.Patch.Class
66−import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67−import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
68−
69−import Control.Lens
70−import Data.List
71−import Data.Map (Map)
72−import qualified Data.Map as Map
73−import Data.Proxy
74−#if !MIN_VERSION_base(4,11,0)
75−import Data.Semigroup (Semigroup (..))
76−#endif
77−import Data.Traversable (foldMapDefault)
78−
79−-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
80−-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
81−-- and vice versa. There should never be any unpaired From/To keys.
82−newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
83− { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
84− unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
85− }
86− deriving ( Show, Read, Eq, Ord
87−-- Haddock cannot handle documentation here before GHC 8.6
88− ,
89−#if __GLASGOW_HASKELL__ >= 806
90− -- | Compose patches having the same effect as applying the
91− -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92− -- 'applyAlways' q@
93−#endif
94− Semigroup
95− , Monoid
96− )
97−
98−pattern Coerce :: Coercible a b => a -> b
99−pattern Coerce x <- (coerce -> x)
100− where Coerce x = coerce x
101−
102−{-# COMPLETE PatchMapWithMove #-}
103−pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
104−-- | Extract the representation of the 'PatchMapWithMove' as a map of
105−-- 'NodeInfo'.
106−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
107−pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
108−
109−_PatchMapWithMove
110− :: Iso
111− (PatchMapWithMove k0 v0)
112− (PatchMapWithMove k1 v1)
113− (Map k0 (NodeInfo k0 v0))
114− (Map k1 (NodeInfo k1 v1))
115−_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
116−
117−instance Functor (PatchMapWithMove k) where
118− fmap f = runIdentity . traverse (Identity . f)
119−
120−instance Foldable (PatchMapWithMove k) where
121− foldMap = foldMapDefault
122−
123−instance Traversable (PatchMapWithMove k) where
124− traverse =
125− _PatchMapWithMove .
126− traverse .
127− traverse
128−
129−instance FunctorWithIndex k (PatchMapWithMove k)
130−instance FoldableWithIndex k (PatchMapWithMove k)
131−instance TraversableWithIndex k (PatchMapWithMove k) where
132− itraverse = itraversed . Indexed
133− itraversed =
134− _PatchMapWithMove .>
135− itraversed <.
136− traverse
137−
138−-- | Create a 'PatchMapWithMove', validating it
139−patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
140−patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
141−
142−-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
143−patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
144−patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
145−
146−-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
147−insertMapKey :: k -> v -> PatchMapWithMove k v
148−insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
149−
150−-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
151−--
152−-- @
153−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
154−-- @
155−moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
156−moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
157−
158−-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
159−--
160−-- @
161−-- let aMay = Map.lookup a map
162−-- bMay = Map.lookup b map
163−-- in maybe id (Map.insert a) (bMay <> aMay)
164−-- . maybe id (Map.insert b) (aMay <> bMay)
165−-- . Map.delete a . Map.delete b $ map
166−-- @
167−swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
168−swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
169−
170−-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
171−deleteMapKey :: k -> PatchMapWithMove k v
172−deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
173−
174−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
175−--
176−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
177−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178−unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
179−
180−-- | Apply the insertions, deletions, and moves to a given 'Map'
181−instance Ord k => Patch (PatchMapWithMove k v) where
182− type PatchTarget (PatchMapWithMove k v) = Map k v
183− apply (PatchMapWithMove' p) = apply p
184−
185−-- | Returns all the new elements that will be added to the 'Map'.
186−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
187−patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
188−
189−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
190−patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
191−patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
192−
193−-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
194−-- its values using the given ordering function. The set keys of the 'Map' is
195−-- not changed.
196−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
197−patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
198−
199−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
200−-- will produce a 'Map' with the same values as the second 'Map' but with the
201−-- values sorted with the given ordering function.
202−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
203−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204− where newList = Map.toList newByIndexUnsorted
205− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
206−
207−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
208−-- will produce the second 'Map'.
209−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
210−patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
211− PM.patchThatChangesMap oldByIndex newByIndex
212−
213−--
214−-- NodeInfo
215−--
216−
217−-- | Holds the information about each key: where its new value should come from,
218−-- and where its old value should go to
219−newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
220−
221−deriving instance (Show k, Show p) => Show (NodeInfo k p)
222−deriving instance (Read k, Read p) => Read (NodeInfo k p)
223−deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
224−deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
225−
226−{-# COMPLETE NodeInfo #-}
227−pattern NodeInfo :: To k -> From k v -> NodeInfo k v
228−_nodeInfo_to :: NodeInfo k v -> To k
229−_nodeInfo_from :: NodeInfo k v -> From k v
230−pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
231− PM.NodeInfo
232− { PM._nodeInfo_to = _nodeInfo_to
233− , PM._nodeInfo_from = Coerce _nodeInfo_from
234− }
235−
236−_NodeInfo
237− :: Iso
238− (NodeInfo k0 v0)
239− (NodeInfo k1 v1)
240− (PM.NodeInfo k0 (Proxy v0))
241− (PM.NodeInfo k1 (Proxy v1))
242−_NodeInfo = iso unNodeInfo' NodeInfo'
243−
244−instance Functor (NodeInfo k) where
245− fmap f = runIdentity . traverse (Identity . f)
246−
247−instance Foldable (NodeInfo k) where
248− foldMap = foldMapDefault
249−
250−instance Traversable (NodeInfo k) where
251− traverse = bitraverseNodeInfo pure
252−
253−bitraverseNodeInfo
254− :: Applicative f
255− => (k0 -> f k1)
256− -> (v0 -> f v1)
257− -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258−bitraverseNodeInfo fk fv = fmap NodeInfo'
259− . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260− . coerce
261−
262−-- | Change the 'From' value of a 'NodeInfo'
263−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
264−nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
265−
266−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
267−-- 'Applicative', 'Monad', etc.) action to get the new value
268−nodeInfoMapMFrom
269− :: Functor f
270− => (From k v -> f (From k v))
271− -> NodeInfo k v -> f (NodeInfo k v)
272−nodeInfoMapMFrom f = fmap NodeInfo'
273− . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274− . coerce
275−
276−-- | Set the 'To' field of a 'NodeInfo'
277−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
278−nodeInfoSetTo = coerce . PM.nodeInfoSetTo
279−
280−--
281−-- From
282−--
283−
284−-- | Describe how a key's new value should be produced
285−newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
286−
287−{-# COMPLETE From_Insert, From_Delete, From_Move #-}
288−
289−-- | Insert the given value here
290−pattern From_Insert :: v -> From k v
291−pattern From_Insert v = From' (PM.From_Insert v)
292−
293−-- | Delete the existing value, if any, from here
294−pattern From_Delete :: From k v
295−pattern From_Delete = From' PM.From_Delete
296−
297−-- | Move the value here from the given key
298−pattern From_Move :: k -> From k v
299−pattern From_Move k = From' (PM.From_Move k Proxy)
300−
301−bitraverseFrom
302− :: Applicative f
303− => (k0 -> f k1)
304− -> (v0 -> f v1)
305− -> From k0 v0 -> f (From k1 v1)
306−bitraverseFrom fk fv = fmap From'
307− . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308− . coerce
309−
310−makeWrapped ''PatchMapWithMove
311−makeWrapped ''NodeInfo
312−makeWrapped ''From
src/Data/Patch/MapWithPatchingMove.hsdeleted−432
@@ -1,432 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE StandaloneDeriving #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15−-- another
16−module Data.Patch.MapWithPatchingMove
17− ( PatchMapWithPatchingMove (..)
18− , patchMapWithPatchingMove
19− , patchMapWithPatchingMoveInsertAll
20− , insertMapKey
21− , moveMapKey
22− , swapMapKey
23− , deleteMapKey
24− , unsafePatchMapWithPatchingMove
25− , patchMapWithPatchingMoveNewElements
26− , patchMapWithPatchingMoveNewElementsMap
27− , patchThatSortsMapWith
28− , patchThatChangesAndSortsMapWith
29− , patchThatChangesMap
30−
31− -- * Node Info
32− , NodeInfo (..)
33− , bitraverseNodeInfo
34− , nodeInfoMapFrom
35− , nodeInfoMapMFrom
36− , nodeInfoSetTo
37−
38− -- * From
39− , From(..)
40− , bitraverseFrom
41−
42− -- * To
43− , To
44−
45− -- TODO internals module
46− , Fixup (..)
47− ) where
48−
49−import Data.Patch.Class
50−
51−import Control.Lens hiding (from, to)
52−import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
54−import Data.Foldable (toList)
55−import Data.Function
56−import Data.List
57−import Data.Map (Map)
58−import qualified Data.Map as Map
59−import Data.Maybe
60−#if !MIN_VERSION_base(4,11,0)
61−import Data.Semigroup (Semigroup (..))
62−#endif
63−import Data.Monoid.DecidablyEmpty
64−import Data.Set (Set)
65−import qualified Data.Set as Set
66−import Data.These (These (..))
67−
68−-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
69−-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
70−-- and vice versa. There should never be any unpaired From/To keys.
71−newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
72− { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
73− unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
74− }
75−
76−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
77−deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
78−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
79−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
80−
81−deriving instance ( Ord k
82−#if !MIN_VERSION_base(4,11,0)
83− , Semigroup p
84−#endif
85− , DecidablyEmpty p
86− , Patch p
87− ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
88−
89−-- | Create a 'PatchMapWithPatchingMove', validating it
90−patchMapWithPatchingMove
91− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
92−patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
93− where valid = forwardLinks == backwardLinks
94− forwardLinks = Map.mapMaybe _nodeInfo_to m
95− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
96− case _nodeInfo_from p of
97− From_Move from _ -> Just (from, to)
98− _ -> Nothing
99−
100−-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
101−patchMapWithPatchingMoveInsertAll
102− :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
103−patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
104− { _nodeInfo_from = From_Insert v
105− , _nodeInfo_to = Nothing
106− }
107−
108−-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
109−insertMapKey
110− :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
111−insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
112−
113−-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
114−--
115−-- @
116−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
117−-- @
118−moveMapKey
119− :: ( DecidablyEmpty p
120−#if !MIN_VERSION_base(4,11,0)
121− , Semigroup p
122−#endif
123− , Patch p
124− )
125− => Ord k => k -> k -> PatchMapWithPatchingMove k p
126−moveMapKey src dst
127− | src == dst = mempty
128− | otherwise =
129− PatchMapWithPatchingMove $ Map.fromList
130− [ (dst, NodeInfo (From_Move src mempty) Nothing)
131− , (src, NodeInfo From_Delete (Just dst))
132− ]
133−
134−-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
135−--
136−-- @
137−-- let aMay = Map.lookup a map
138−-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
141−-- . Map.delete a . Map.delete b $ map
142−-- @
143−swapMapKey
144− :: ( DecidablyEmpty p
145−#if !MIN_VERSION_base(4,11,0)
146− , Semigroup p
147−#endif
148− , Patch p
149− )
150− => Ord k => k -> k -> PatchMapWithPatchingMove k p
151−swapMapKey src dst
152− | src == dst = mempty
153− | otherwise =
154− PatchMapWithPatchingMove $ Map.fromList
155− [ (dst, NodeInfo (From_Move src mempty) (Just src))
156− , (src, NodeInfo (From_Move dst mempty) (Just dst))
157− ]
158−
159−-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
160−-- the mapping, equivalent to 'Map.delete'.
161−deleteMapKey
162− :: k -> PatchMapWithPatchingMove k v
163−deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
164−
165−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
166−--
167−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
168−unsafePatchMapWithPatchingMove
169− :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
170−unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
171−
172−-- | Apply the insertions, deletions, and moves to a given 'Map'
173−instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
174− type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
175− -- TODO: return Nothing sometimes
176− -- Note: the strict application here is critical to ensuring that incremental
177− -- merges don't hold onto all their prerequisite events forever; can we make
178− -- this more robust?
179− apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
180− where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
181− From_Insert v -> Just v
182− From_Move k p -> applyAlways p <$> Map.lookup k old
183− From_Delete -> Nothing
184− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
185− From_Delete -> Just ()
186− _ -> Nothing
187−
188−-- | Returns all the new elements that will be added to the 'Map'
189−patchMapWithPatchingMoveNewElements
190− :: PatchMapWithPatchingMove k p -> [PatchTarget p]
191−patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
192−
193−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
194−patchMapWithPatchingMoveNewElementsMap
195− :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
196−patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
197− where f ni = case _nodeInfo_from ni of
198− From_Insert v -> Just v
199− From_Move _ _ -> Nothing
200− From_Delete -> Nothing
201−
202−-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
203−-- its values using the given ordering function. The set keys of the 'Map' is
204−-- not changed.
205−patchThatSortsMapWith
206− :: (Ord k, Monoid p)
207− => (PatchTarget p -> PatchTarget p -> Ordering)
208− -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
209−patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
210− where unsorted = Map.toList m
211− sorted = sortBy (cmp `on` snd) unsorted
212− f (to, _) (from, _) = if to == from then Nothing else
213− Just (from, to)
214− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
215− g (to, _) (from, _) = if to == from then Nothing else
216− let Just movingTo = Map.lookup from reverseMapping
217− in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
218−
219−-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
220−-- will produce a 'Map' with the same values as the second 'Map' but with the
221−-- values sorted with the given ordering function.
222−patchThatChangesAndSortsMapWith
223− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
224− => (PatchTarget p -> PatchTarget p -> Ordering)
225− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
226−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
227− where newList = Map.toList newByIndexUnsorted
228− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
229−
230−-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231−-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233−patchThatChangesMap
234− :: forall k p
235− . (Ord k, Ord (PatchTarget p), Monoid p)
236− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237−patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
243− unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
245− -- Generate patch info for a single value
246− -- Keys that are found in both the old and new sets will not be patched
247− -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
248− -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
252− That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
256− patchSingleValueThese v = \case
257− This oldKeys -> patchSingleValue v oldKeys mempty
258− That newKeys -> patchSingleValue v mempty newKeys
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
260− -- Generate froms and tos for all values, then merge them together
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
263− This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
265− These from to -> NodeInfo from to
266−
267−--
268−-- NodeInfo
269−--
270−
271−-- | Holds the information about each key: where its new value should come from,
272−-- and where its old value should go to
273−data NodeInfo k p = NodeInfo
274− { _nodeInfo_from :: !(From k p)
275− -- ^ Where do we get the new value for this key?
276− , _nodeInfo_to :: !(To k)
277− -- ^ If the old value is being kept (i.e. moved rather than deleted or
278− -- replaced), where is it going?
279− }
280−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
281−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
284−
285−-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of
286−-- the type families here, this doesn't it any bi- or tri-traversal class.
287−bitraverseNodeInfo
288− :: Applicative f
289− => (k0 -> f k1)
290− -> (p0 -> f p1)
291− -> (PatchTarget p0 -> f (PatchTarget p1))
292− -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
293−bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
294− <$> bitraverseFrom fk fp fpt from
295− <*> traverse fk to
296−
297−-- | Change the 'From' value of a 'NodeInfo'
298−nodeInfoMapFrom
299− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
300−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
301−
302−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
303−-- 'Applicative', 'Monad', etc.) action to get the new value
304−nodeInfoMapMFrom
305− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
306−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
307−
308−-- | Set the 'To' field of a 'NodeInfo'
309−nodeInfoSetTo
310− :: To k -> NodeInfo k v -> NodeInfo k v
311−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
312−
313−--
314−-- From
315−--
316−
317−-- | Describe how a key's new value should be produced
318−data From k p
319− = From_Insert (PatchTarget p) -- ^ Insert the given value here
320− | From_Delete -- ^ Delete the existing value, if any, from here
321− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
322−
323−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
324−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
327−
328−-- | Traverse the 'From' over the key, patch, and patch target. Because of
329−-- the type families here, this doesn't it any bi- or tri-traversal class.
330−bitraverseFrom
331− :: Applicative f
332− => (k0 -> f k1)
333− -> (p0 -> f p1)
334− -> (PatchTarget p0 -> f (PatchTarget p1))
335− -> From k0 p0 -> f (From k1 p1)
336−bitraverseFrom fk fp fpt = \case
337− From_Insert pt -> From_Insert <$> fpt pt
338− From_Delete -> pure From_Delete
339− From_Move k p -> From_Move <$> fk k <*> fp p
340−
341−--
342−-- To
343−--
344−
345−-- | Describe where a key's old value will go. If this is 'Just', that means
346−-- the key's old value will be moved to the given other key; if it is 'Nothing',
347−-- that means it will be deleted.
348−type To = Maybe
349−
350−--
351−-- Fixup
352−--
353−
354−-- | Helper data structure used for composing patches using the monoid instance.
355−data Fixup k v
356− = Fixup_Delete
357− | Fixup_Update (These (From k v) (To k))
358−
359−-- | Compose patches having the same effect as applying the patches in turn:
360−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
361−instance ( Ord k
362−#if !MIN_VERSION_base(4,11,0)
363− , Semigroup p
364−#endif
365− , DecidablyEmpty p
366− , Patch p
367− ) => Semigroup (PatchMapWithPatchingMove k p) where
368− PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
369− where
370− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
371− h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
372− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
373− (Just toAfter, From_Move fromBefore p)
374− | fromBefore == toAfter && isEmpty p
375− -> [(toAfter, Fixup_Delete)]
376− | otherwise
377− -> [ (toAfter, Fixup_Update (This editBefore))
378− , (fromBefore, Fixup_Update (That mToAfter))
379− ]
380− (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
381− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
382− (Nothing, _) -> []
383− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
384− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
385− | This x <- a, That y <- b
386− = Fixup_Update $ These x y
387− | That y <- a, This x <- b
388− = Fixup_Update $ These x y
389− mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
390− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
391− combineNodeInfos _ nia nib = NodeInfo
392− { _nodeInfo_from = _nodeInfo_from nia
393− , _nodeInfo_to = _nodeInfo_to nib
394− }
395− applyFixup _ ni = \case
396− Fixup_Delete -> Nothing
397− Fixup_Update u -> Just $ NodeInfo
398− { _nodeInfo_from = case _nodeInfo_from ni of
399− f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
400− Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
401− Just (From_Insert v) -> From_Insert $ applyAlways p' v
402− Just From_Delete -> From_Delete
403− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
404− _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
405− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
406− }
407− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
408− getHere :: These a b -> Maybe a
409− getHere = \case
410− This a -> Just a
411− These a _ -> Just a
412− That _ -> Nothing
413− getThere :: These a b -> Maybe b
414− getThere = \case
415− This _ -> Nothing
416− These _ b -> Just b
417− That b -> Just b
418−
419−--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
420−-- | Compose patches having the same effect as applying the patches in turn:
421−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
422−instance ( Ord k
423−#if !MIN_VERSION_base(4,11,0)
424− , Semigroup p
425−#endif
426− , DecidablyEmpty p
427− , Patch p
428− ) => Monoid (PatchMapWithPatchingMove k p) where
429− mempty = PatchMapWithPatchingMove mempty
430− mappend = (<>)
431−
432−makeWrapped ''PatchMapWithPatchingMove
src/Data/Semigroup/Additive.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
4−-- |
5−-- Module:
6−-- Data.Semigroup.Additive
7−-- Description:
8−-- This module defines a class for commutative semigroups, until it is moved
9−-- to another library.
10−module Data.Semigroup.Additive
11− ( Additive
12− ) where
13−
14−import Data.Functor.Const (Const (..))
15−import Data.Functor.Identity
16−import Data.Proxy
17−#if !MIN_VERSION_base(4,12,0)
18−-- for :*: and :.: semigroup instances
19−import Data.Orphans ()
20−#endif
21−#if !MIN_VERSION_base(4,11,0)
22−import Data.Semigroup (Semigroup (..))
23−#endif
24−import GHC.Generics
25−
26−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
27−class Semigroup q => Additive q where
28−
29−-- | Trivial additive semigroup.
30−instance Additive ()
31−
32−-- | Product additive semigroup.
33−-- A Pair of additive semigroups gives rise to a additive semigroup
34−instance (Additive a, Additive b) => Additive (a, b)
35−
36−-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
37−-- Base does not define Monoid (Compose f g a) so this is the best we can
38−-- really do for functor composition.
39−instance Additive (f (g a)) => Additive ((f :.: g) a)
40−
41−-- | Product of additive semigroups, Functor style.
42−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
43−
44−-- | Trivial additive semigroup, Functor style
45−instance Additive (Proxy x)
46−
47−-- | Const lifts additive semigroups into a functor.
48−instance Additive a => Additive (Const a x)
49−
50−-- | Identity lifts additive semigroups pointwise (at only one point)
51−instance Additive a => Additive (Identity a)
52−
53−-- | Functions lift additive semigroups pointwise.
54−instance Additive b => Additive (a -> b)
src/Data/WeakBag.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ExistentialQuantification #-}
4+#ifdef USE_REFLEX_OPTIMIZER
5+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
6+#endif
7+-- | This module defines the 'WeakBag' type, which represents a mutable
8+-- collection of items that does not cause the items to be retained in memory.
9+-- This is useful for situations where a value needs to be inspected or modified
10+-- if it is still alive, but can be ignored if it is dead.
11+module Data.WeakBag
12+ ( WeakBag
13+ , WeakBagTicket
14+ , empty
15+ , singleton
16+ , insert
17+ , traverse
18+ , remove
19+ -- * Internal functions
20+ -- These will not always be available.
21+ , _weakBag_children --TODO: Don't export this
22+ ) where
23+
24+import Control.Exception
25+import Control.Monad hiding (forM_, mapM_)
26+import Control.Monad.IO.Class
27+import Data.Foldable (forM_, mapM_)
28+import Data.IntMap.Strict (IntMap)
29+import qualified Data.IntMap.Strict as IntMap
30+import Data.IORef
31+import System.Mem.Weak
32+
33+import Prelude hiding (mapM_, traverse)
34+
35+-- | A @WeakBag a@ holds a set of values of type @a@, but does not retain them -
36+-- that is, they can still be garbage-collected. As long as the @a@s remain
37+-- alive, the 'WeakBag' will continue to refer to them.
38+data WeakBag a = WeakBag
39+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
40+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
41+ }
42+
43+-- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned. If
44+-- the caller retains the ticket, the item is guranteed to stay in memory (and
45+-- thus in the 'WeakBag'). The ticket can also be used to remove the item from
46+-- the 'WeakBag' prematurely (i.e. while it is still alive), using 'remove'.
47+data WeakBagTicket = forall a. WeakBagTicket
48+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
49+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
50+ }
51+
52+-- | Insert an item into a 'WeakBag'.
53+{-# INLINE insert #-}
54+insert :: a -- ^ The item
55+ -> WeakBag a -- ^ The 'WeakBag' to insert into
56+ -> IORef (Weak b) -- ^ An arbitrary value to be used in the following
57+ -- callback
58+ -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed
59+ -- (whether automatically by the item being garbage
60+ -- collected or manually via 'remove')
61+ -> IO WeakBagTicket -- ^ Returns a 'WeakBagTicket' that ensures the item
62+ -- is retained and allows the item to be removed.
63+insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do
64+ a' <- evaluate a
65+ wbRef' <- evaluate wbRef
66+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
67+ let cleanup = do
68+ wb <- readIORef wbRef'
69+ mb <- deRefWeak wb
70+ forM_ mb $ \b -> do
71+ csWithoutMe <- atomicModifyIORef children $ \cs ->
72+ let !csWithoutMe = IntMap.delete myId cs
73+ in (csWithoutMe, csWithoutMe)
74+ when (IntMap.null csWithoutMe) $ finalizer b
75+ return ()
76+ return ()
77+ wa <- mkWeakPtr a' $ Just cleanup
78+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
79+ return $ WeakBagTicket
80+ { _weakBagTicket_weakItem = wa
81+ , _weakBagTicket_item = a'
82+ }
83+
84+-- | Create an empty 'WeakBag'.
85+{-# INLINE empty #-}
86+empty :: IO (WeakBag a)
87+empty = {-# SCC "empty" #-} do
88+ nextId <- newIORef 1
89+ children <- newIORef IntMap.empty
90+ let bag = WeakBag
91+ { _weakBag_nextId = nextId
92+ , _weakBag_children = children
93+ }
94+ return bag
95+
96+-- | Create a 'WeakBag' with one item; equivalent to creating the 'WeakBag' with
97+-- 'empty', then using 'insert'.
98+{-# INLINE singleton #-}
99+singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket)
100+singleton a wbRef finalizer = {-# SCC "singleton" #-} do
101+ bag <- empty
102+ ticket <- insert a bag wbRef finalizer
103+ return (bag, ticket)
104+
105+{-# INLINE traverse #-}
106+-- | Visit every node in the given list. If new nodes are appended during the
107+-- traversal, they will not be visited. Every live node that was in the list
108+-- when the traversal began will be visited exactly once; however, no guarantee
109+-- is made about the order of the traversal.
110+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
111+traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do
112+ cs <- liftIO $ readIORef children
113+ forM_ cs $ \c -> do
114+ ma <- liftIO $ deRefWeak c
115+ mapM_ f ma
116+
117+-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times
118+-- on the same 'WeakBagTicket'.
119+{-# INLINE remove #-}
120+remove :: WeakBagTicket -> IO ()
121+remove (WeakBagTicket w _) = {-# SCC "remove" #-} finalize w
122+--TODO: Should 'remove' also drop the reference to the item?
123+
124+--TODO: can/should we provide a null WeakBagTicket?
src/Reflex.hsnew file+26
@@ -0,0 +1,26 @@
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.EventWriter as X
10+import Reflex.Dynamic as X
11+#ifdef USE_TEMPLATE_HASKELL
12+import Reflex.Dynamic.TH as X
13+#endif
14+import Reflex.Dynamic.Uniq as X
15+import Reflex.DynamicWriter as X
16+import Reflex.PerformEvent.Base as X
17+import Reflex.PerformEvent.Class as X
18+import Reflex.PostBuild.Base as X
19+import Reflex.PostBuild.Class as X
20+import Reflex.Query.Base as X
21+import Reflex.Query.Class as X
22+import Reflex.Requester.Base as X
23+import Reflex.Requester.Class as X
24+import Reflex.Spider as X
25+import Reflex.TriggerEvent.Base as X
26+import Reflex.TriggerEvent.Class as X
src/Reflex/Class.hsnew file+1145
@@ -0,0 +1,1145 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE NoMonomorphismRestriction #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE RecursiveDo #-}
12+{-# LANGUAGE RoleAnnotations #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+#ifdef USE_REFLEX_OPTIMIZER
18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
19+#endif
20+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
21+{-# LANGUAGE EmptyDataDecls #-}
22+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
23+#endif
24+
25+-- | This module contains the Reflex interface, as well as a variety of
26+-- convenience functions for working with 'Event's, 'Behavior's, and other
27+-- signals.
28+module Reflex.Class
29+ ( module Reflex.Patch
30+ -- * Primitives
31+ , Reflex (..)
32+ , mergeInt
33+ , coerceBehavior
34+ , coerceEvent
35+ , coerceDynamic
36+ , MonadSample (..)
37+ , MonadHold (..)
38+ -- ** 'fan'-related types
39+ , EventSelector (..)
40+ , EventSelectorInt (..)
41+ -- ** 'Incremental'-related types
42+ -- * Convenience functions
43+ , constDyn
44+ , pushAlways
45+ -- ** Combining 'Event's
46+ , leftmost
47+ , mergeMap
48+ , mergeMapIncremental
49+ , mergeMapIncrementalWithMove
50+ , mergeList
51+ , mergeWith
52+ , difference
53+ , alignEventWithMaybe
54+ -- ** Breaking up 'Event's
55+ , splitE
56+ , fanEither
57+ , fanThese
58+ , fanMap
59+ , dmapToThese
60+ , EitherTag (..)
61+ , eitherToDSum
62+ , dsumToEither
63+ -- ** Switching between 'Event's
64+ , switchPromptly
65+ , switchPromptOnly
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+ , mapAccum_
82+ , mapAccumM_
83+ , mapAccumMaybe_
84+ , mapAccumMaybeM_
85+ , zipListWithEvent
86+ , numberOccurrences
87+ , numberOccurrencesFrom
88+ , (<@>)
89+ , (<@)
90+ , headE
91+ , tailE
92+ , headTailE
93+ , takeWhileE
94+ , switcher
95+ -- * Debugging functions
96+ , traceEvent
97+ , traceEventWith
98+ -- * Unsafe functions
99+ , unsafeDynamic
100+ , unsafeMapIncremental
101+ -- * 'FunctorMaybe'
102+ , FunctorMaybe (..)
103+ , fforMaybe
104+ , ffilter
105+ -- * Miscellaneous convenience functions
106+ , ffor
107+ , MonadAdjust (..)
108+ , sequenceDMapWithAdjust
109+ , sequenceDMapWithAdjustWithMove
110+ , mapMapWithAdjustWithMove
111+ -- * Deprecated functions
112+ , appendEvents
113+ , onceE
114+ , sequenceThese
115+ , fmapMaybeCheap
116+ , fmapCheap
117+ , fforCheap
118+ , fforMaybeCheap
119+ , pushAlwaysCheap
120+ , tagCheap
121+ , mergeWithCheap
122+ , mergeWithCheap'
123+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
124+ , Spider
125+ , SpiderEnv
126+ , SpiderTimeline
127+ , Global
128+ , Behavior (..)
129+ , Event (..)
130+ , Dynamic (..)
131+ , Incremental (..)
132+ , never
133+ , constant
134+ , push
135+ , pushCheap
136+ , pull
137+ , merge
138+ , fan
139+ , switch
140+ , coincidence
141+ , current
142+ , updated
143+ , unsafeBuildDynamic
144+ , unsafeBuildIncremental
145+ , mergeIncremental
146+ , mergeIncrementalWithMove
147+ , currentIncremental
148+ , updatedIncremental
149+ , incrementalToDynamic
150+ , behaviorCoercion
151+ , eventCoercion
152+ , dynamicCoercion
153+#endif
154+ ) where
155+
156+import Control.Applicative
157+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
158+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
159+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
160+import Control.Monad.Trans.Cont (ContT ())
161+import Control.Monad.Trans.Except (ExceptT ())
162+import Control.Monad.Trans.RWS (RWST ())
163+import Control.Monad.Trans.Writer (WriterT ())
164+import Data.Align
165+import Data.Bifunctor
166+import Data.Coerce
167+import Data.Default
168+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
169+import qualified Data.Dependent.Map as DMap
170+import Data.Either
171+import Data.Foldable
172+import Data.Functor.Bind hiding (join)
173+import qualified Data.Functor.Bind as Bind
174+import Data.Functor.Constant
175+import Data.Functor.Misc
176+import Data.Functor.Plus
177+import Data.IntMap.Strict (IntMap)
178+import qualified Data.IntMap.Strict as IntMap
179+import Data.List.NonEmpty (NonEmpty (..))
180+import Data.Map (Map)
181+import Data.Maybe
182+import Data.Monoid hiding (Alt, (<>))
183+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
184+import Data.String
185+import Data.These
186+import Data.Traversable
187+import Data.Type.Coercion
188+import Reflex.FunctorMaybe
189+import Reflex.Patch
190+import Data.FastMutableIntMap (PatchIntMap)
191+
192+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
193+import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),
194+ SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,
195+ dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,
196+ dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,
197+ runFrame, runSpiderHostFrame)
198+import qualified Reflex.Spider.Internal
199+import qualified Reflex.Spider.Internal as S
200+import Unsafe.Coerce
201+#endif
202+
203+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
204+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
205+
206+import Debug.Trace (trace)
207+
208+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
209+#include "Spider/SpiderTimeline.include.hs"
210+#endif
211+
212+-- | The 'Reflex' class contains all the primitive functionality needed for
213+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates
214+-- which "timeline" is in use. Timelines are fully-independent FRP contexts,
215+-- and the type of the timeline determines the FRP engine to be used. For most
216+-- purposes, the 'Reflex.Spider' implementation is recommended.
217+class ( MonadHold t (PushM t)
218+ , MonadSample t (PullM t)
219+ , MonadFix (PushM t)
220+ , Functor (Dynamic t)
221+ , Applicative (Dynamic t) -- Necessary for GHC <= 7.8
222+ , Monad (Dynamic t)
223+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
224+ , t ~ SpiderTimeline Global
225+#endif
226+ ) => Reflex t where
227+ -- | A container for a value that can change over time. 'Behavior's can be
228+ -- sampled at will, but it is not possible to be notified when they change
229+ data Behavior t :: * -> *
230+ -- | A stream of occurrences. During any given frame, an 'Event' is either
231+ -- occurring or not occurring; if it is occurring, it will contain a value of
232+ -- the given type (its "occurrence type")
233+ data Event t :: * -> *
234+ -- | A container for a value that can change over time and allows
235+ -- notifications on changes. Basically a combination of a 'Behavior' and an
236+ -- 'Event', with a rule that the 'Behavior' will change if and only if the
237+ -- 'Event' fires.
238+ data Dynamic t :: * -> *
239+ -- | An 'Incremental' is a more general form of a 'Dynamic'.
240+ -- Instead of always fully replacing the value, only parts of it can be patched.
241+ -- This is only needed for performance critical code via `mergeIncremental` to make small
242+ -- changes to large values.
243+ data Incremental t :: * -> *
244+ -- | A monad for doing complex push-based calculations efficiently
245+ type PushM t :: * -> *
246+ -- | A monad for doing complex pull-based calculations efficiently
247+ type PullM t :: * -> *
248+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
249+ -- | An 'Event' with no occurrences
250+ never :: Event t a
251+ -- | Create a 'Behavior' that always has the given value
252+ 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
253+ -- | Create an 'Event' from another 'Event'; the provided function can sample
254+ -- 'Behavior's and hold 'Event's, and use the results to produce a occurring
255+ -- (Just) or non-occurring (Nothing) result
256+ push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
257+ -- | 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.
258+ pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
259+ -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be
260+ -- recomputed whenever any of the read 'Behavior's changes
261+ pull :: PullM t a -> Behavior t a
262+ -- | Merge a collection of events; the resulting 'Event' will only occur if at
263+ -- least one input event is occuring, and will contain all of the input keys
264+ -- that are occurring simultaneously
265+ 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
266+ -- | Efficiently fan-out an event to many destinations. This function should
267+ -- be partially applied, and then the result applied repeatedly to create
268+ -- child events
269+ 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
270+ -- | Create an 'Event' that will occur whenever the currently-selected input
271+ -- 'Event' occurs
272+ switch :: Behavior t (Event t a) -> Event t a
273+ -- | Create an 'Event' that will occur whenever the input event is occurring
274+ -- and its occurrence value, another 'Event', is also occurring
275+ coincidence :: Event t (Event t a) -> Event t a
276+ -- | Extract the 'Behavior' of a 'Dynamic'.
277+ current :: Dynamic t a -> Behavior t a
278+ -- | Extract the 'Event' of the 'Dynamic'.
279+ updated :: Dynamic t a -> Event t a
280+ -- | Create a new 'Dynamic'. The given 'PullM' must always return the most
281+ -- recent firing of the given 'Event', if any.
282+ unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
283+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change
284+ -- in the same way that the accumulated application of patches would change
285+ -- that value.
286+ unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
287+ -- | Create a merge whose parents can change over time
288+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
289+ -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
290+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
291+ -- | Extract the 'Behavior' component of an 'Incremental'
292+ currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
293+ -- | Extract the 'Event' component of an 'Incremental'
294+ updatedIncremental :: Patch p => Incremental t p -> Event t p
295+ -- | Convert an 'Incremental' to a 'Dynamic'
296+ incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)
297+ -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its
298+ -- occurrence type
299+ behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)
300+ -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its
301+ -- occurrence type
302+ eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)
303+ -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
304+ -- occurrence type
305+ dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
306+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
307+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a
308+#endif
309+
310+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
311+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
312+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
313+
314+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
315+instance t ~ SpiderTimeline Global => Reflex t where
316+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }
317+ newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }
318+ newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Reflex.Spider.Internal.Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)
319+ newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Reflex.Spider.Internal.Dynamic Global p }
320+ type PullM t = SpiderPullM Global
321+ type PushM t = SpiderPushM Global
322+never :: Reflex t => Event t a
323+constant :: Reflex t => a -> Behavior t a
324+push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b
325+pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b
326+pull :: Reflex t => PullM t a -> Behavior t a
327+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
328+fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k
329+switch :: Reflex t => Behavior t (Event t a) -> Event t a
330+coincidence :: Reflex t => Event t (Event t a) -> Event t a
331+current :: Reflex t => Dynamic t a -> Behavior t a
332+updated :: Reflex t => Dynamic t a -> Event t a
333+unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a
334+unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p
335+mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
336+mergeIncrementalWithMove :: (Reflex t, GCompare k) => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
337+currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)
338+updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p
339+incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)
340+behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)
341+eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)
342+dynamicCoercion :: Reflex t => Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
343+{-# INLINE never #-}
344+never = SpiderEvent S.eventNever
345+{-# INLINE constant #-}
346+constant = SpiderBehavior . S.behaviorConst
347+{-# INLINE push #-}
348+push f = SpiderEvent . S.push (coerce f) . unSpiderEvent
349+{-# INLINE pushCheap #-}
350+pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent
351+{-# INLINE pull #-}
352+pull = SpiderBehavior . S.pull . coerce
353+{-# INLINE merge #-}
354+merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))
355+{-# INLINE fan #-}
356+fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))
357+{-# INLINE switch #-}
358+switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior
359+{-# INLINE coincidence #-}
360+coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent
361+{-# INLINE current #-}
362+current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic
363+{-# INLINE updated #-}
364+updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic
365+{-# INLINE unsafeBuildDynamic #-}
366+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
367+{-# INLINE unsafeBuildIncremental #-}
368+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ S.unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
369+{-# INLINE mergeIncremental #-}
370+mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental
371+{-# INLINE mergeIncrementalWithMove #-}
372+mergeIncrementalWithMove = SpiderEvent . S.mergeWithMove . (unsafeCoerce :: S.Dynamic x (PatchDMapWithMove k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMapWithMove k (S.Event x))) . unSpiderIncremental
373+{-# INLINE currentIncremental #-}
374+currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
375+{-# INLINE updatedIncremental #-}
376+updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
377+{-# INLINE incrementalToDynamic #-}
378+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do
379+ c <- readBehaviorUntracked $ dynamicCurrent i
380+ return $ Identity <$> apply p c
381+eventCoercion Coercion = Coercion
382+behaviorCoercion Coercion = Coercion
383+dynamicCoercion = unsafeCoerce
384+#endif
385+
386+-- | Coerce a 'Behavior' between representationally-equivalent value types
387+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b
388+coerceBehavior = coerceWith $ behaviorCoercion Coercion
389+
390+-- | Coerce an 'Event' between representationally-equivalent occurrence types
391+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b
392+coerceEvent = coerceWith $ eventCoercion Coercion
393+
394+-- | Coerce a 'Dynamic' between representationally-equivalent value types
395+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
396+coerceDynamic = coerceWith $ dynamicCoercion Coercion
397+
398+-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
399+-- _must_ change when and only when the 'Event' fires, such that the
400+-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
401+-- if this is not the case, the resulting 'Dynamic' will behave
402+-- nondeterministically.
403+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
404+unsafeDynamic = unsafeBuildDynamic . sample
405+
406+-- | Construct a 'Dynamic' value that never changes
407+constDyn :: Reflex t => a -> Dynamic t a
408+constDyn = pure
409+
410+instance (Reflex t, Default a) => Default (Dynamic t a) where
411+ def = pure def
412+
413+-- | 'MonadSample' designates monads that can read the current value of a
414+-- 'Behavior'. This includes both 'PullM' and 'PushM'.
415+class (Applicative m, Monad m) => MonadSample t m | m -> t where
416+ -- | Get the current value in the 'Behavior'
417+ sample :: Behavior t a -> m a
418+
419+-- | 'MonadHold' designates monads that can create new 'Behavior's based on
420+-- 'Event's; usually this will be 'PushM' or a monad based on it. 'MonadHold'
421+-- is required to create any stateful computations with Reflex.
422+class MonadSample t m => MonadHold t m where
423+ -- | Create a new 'Behavior' whose value will initially be equal to the given
424+ -- value and will be updated whenever the given 'Event' occurs. The update
425+ -- takes effect immediately after the 'Event' occurs; if the occurrence that
426+ -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample
427+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new
428+ -- one.
429+ hold :: a -> Event t a -> m (Behavior t a)
430+ default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)
431+ hold v0 = lift . hold v0
432+ -- | Create a 'Dynamic' value using the given initial value that changes every
433+ -- time the 'Event' occurs.
434+ holdDyn :: a -> Event t a -> m (Dynamic t a)
435+ default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)
436+ holdDyn v0 = lift . holdDyn v0
437+ -- | Create an 'Incremental' value using the given initial value that changes
438+ -- every time the 'Event' occurs.
439+ holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
440+ default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
441+ holdIncremental v0 = lift . holdIncremental v0
442+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)
443+ default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
444+ buildDynamic getV0 = lift . buildDynamic getV0
445+
446+-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a
447+-- key. This is much more efficient than filtering for each key with
448+-- 'fmapMaybe'.
449+newtype EventSelector t k = EventSelector
450+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
451+ -- determined by the type of the key, so this can be used to fan-out
452+ -- 'Event's whose sub-'Event's have different types.
453+ --
454+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
455+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant
456+ -- occurrences of an 'Event'.
457+ select :: forall a. k a -> Event t a
458+ }
459+
460+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
461+
462+--------------------------------------------------------------------------------
463+-- Instances
464+--------------------------------------------------------------------------------
465+
466+instance MonadSample t m => MonadSample t (ReaderT r m) where
467+ sample = lift . sample
468+
469+instance MonadHold t m => MonadHold t (ReaderT r m) where
470+ hold a0 = lift . hold a0
471+ holdDyn a0 = lift . holdDyn a0
472+ holdIncremental a0 = lift . holdIncremental a0
473+ buildDynamic a0 = lift . buildDynamic a0
474+
475+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
476+ sample = lift . sample
477+
478+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
479+ hold a0 = lift . hold a0
480+ holdDyn a0 = lift . holdDyn a0
481+ holdIncremental a0 = lift . holdIncremental a0
482+ buildDynamic a0 = lift . buildDynamic a0
483+
484+instance MonadSample t m => MonadSample t (StateT s m) where
485+ sample = lift . sample
486+
487+instance MonadHold t m => MonadHold t (StateT s m) where
488+ hold a0 = lift . hold a0
489+ holdDyn a0 = lift . holdDyn a0
490+ holdIncremental a0 = lift . holdIncremental a0
491+ buildDynamic a0 = lift . buildDynamic a0
492+
493+instance MonadSample t m => MonadSample t (ExceptT e m) where
494+ sample = lift . sample
495+
496+instance MonadHold t m => MonadHold t (ExceptT e m) where
497+ hold a0 = lift . hold a0
498+ holdDyn a0 = lift . holdDyn a0
499+ holdIncremental a0 = lift . holdIncremental a0
500+
501+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
502+ sample = lift . sample
503+
504+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
505+ hold a0 = lift . hold a0
506+ holdDyn a0 = lift . holdDyn a0
507+ holdIncremental a0 = lift . holdIncremental a0
508+
509+instance MonadSample t m => MonadSample t (ContT r m) where
510+ sample = lift . sample
511+
512+instance MonadHold t m => MonadHold t (ContT r m) where
513+ hold a0 = lift . hold a0
514+ holdDyn a0 = lift . holdDyn a0
515+ holdIncremental a0 = lift . holdIncremental a0
516+
517+--------------------------------------------------------------------------------
518+-- Convenience functions
519+--------------------------------------------------------------------------------
520+
521+-- | Create an 'Event' from another 'Event'. The provided function can sample
522+-- 'Behavior's and hold 'Event's.
523+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
524+pushAlways f = push (fmap Just . f)
525+
526+-- | Flipped version of 'fmap'.
527+ffor :: Functor f => f a -> (a -> b) -> f b
528+ffor = flip fmap
529+
530+instance Reflex t => Applicative (Behavior t) where
531+ pure = constant
532+ f <*> x = pull $ sample f `ap` sample x
533+ _ *> b = b
534+ a <* _ = a
535+
536+instance Reflex t => Apply (Behavior t) where
537+ (<.>) = (<*>)
538+
539+instance Reflex t => Bind (Behavior t) where
540+ (>>-) = (>>=)
541+
542+instance (Reflex t, Fractional a) => Fractional (Behavior t a) where
543+ (/) = liftA2 (/)
544+ fromRational = pure . fromRational
545+ recip = fmap recip
546+
547+instance Reflex t => Functor (Behavior t) where
548+ fmap f = pull . fmap f . sample
549+
550+instance (Reflex t, IsString a) => IsString (Behavior t a) where
551+ fromString = pure . fromString
552+
553+instance Reflex t => Monad (Behavior t) where
554+ a >>= f = pull $ sample a >>= sample . f
555+ -- 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.
556+ return = constant
557+ fail = error "Monad (Behavior t) does not support fail"
558+
559+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
560+ mempty = constant mempty
561+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
562+ mconcat = pull . fmap mconcat . mapM sample
563+
564+instance (Reflex t, Num a) => Num (Behavior t a) where
565+ (+) = liftA2 (+)
566+ (-) = liftA2 (-)
567+ (*) = liftA2 (*)
568+ abs = fmap abs
569+ fromInteger = pure . fromInteger
570+ negate = fmap negate
571+ signum = fmap signum
572+
573+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
574+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
575+ sconcat = pull . fmap sconcat . mapM sample
576+#if MIN_VERSION_semigroups(0,17,0)
577+ stimes n = fmap $ stimes n
578+#else
579+ times1p n = fmap $ times1p n
580+#endif
581+
582+-- | Flipped version of 'fmapMaybe'.
583+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
584+fforMaybe = flip fmapMaybe
585+
586+-- | Filter 'f a' using the provided predicate.
587+-- Relies on 'fforMaybe'.
588+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
589+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
590+
591+-- | Left-biased event union (prefers left event on simultaneous
592+-- occurrence).
593+instance Reflex t => Alt (Event t) where
594+ ev1 <!> ev2 = leftmost [ev1, ev2]
595+
596+-- | 'Event' intersection (convenient interface to 'coincidence').
597+instance Reflex t => Apply (Event t) where
598+ evf <.> evx = coincidence (fmap (<$> evx) evf)
599+
600+-- | 'Event' intersection (convenient interface to 'coincidence').
601+instance Reflex t => Bind (Event t) where
602+ evx >>- f = coincidence (f <$> evx)
603+ join = coincidence
604+
605+instance Reflex t => Functor (Event t) where
606+ {-# INLINE fmap #-}
607+ fmap f = fmapMaybe $ Just . f
608+
609+instance Reflex t => FunctorMaybe (Event t) where
610+ {-# INLINE fmapMaybe #-}
611+ fmapMaybe f = push $ return . f
612+
613+-- | Never: @'zero' = 'never'@.
614+instance Reflex t => Plus (Event t) where
615+ zero = never
616+
617+-- | Replace each occurrence value of the 'Event' with the value of the
618+-- 'Behavior' at the time of that occurrence.
619+tag :: Reflex t => Behavior t b -> Event t a -> Event t b
620+tag b = pushAlways $ \_ -> sample b
621+
622+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the
623+-- current value of the 'Behavior'.
624+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
625+attach = attachWith (,)
626+
627+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by
628+-- combining it with the current value of the 'Behavior'.
629+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
630+attachWith f = attachWithMaybe $ \a b -> Just $ f a b
631+
632+-- | Create a new 'Event' by combining each occurence with the current value of
633+-- the 'Behavior'. The occurrence is discarded if the combining function returns
634+-- Nothing
635+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
636+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
637+
638+-- | Create a new 'Event' that only occurs only once, on the first occurence of
639+-- the supplied 'Event'.
640+headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
641+headE e = do
642+ rec be <- hold e $ fmap (const never) e'
643+ let e' = switch be
644+ return e'
645+
646+-- | Create a new 'Event' that occurs on all but the first occurence of the
647+-- supplied 'Event'.
648+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
649+tailE e = snd <$> headTailE e
650+
651+-- | Create a tuple of two 'Event's with the first one occuring only the first
652+-- time the supplied 'Event' occurs and the second occuring on all but the first
653+-- occurence.
654+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
655+headTailE e = do
656+ eHead <- headE e
657+ be <- hold never $ fmap (const e) eHead
658+ return (eHead, switch be)
659+
660+-- | Starting at the current time, fire all the occurrences of the 'Event' for
661+-- which the given predicate returns 'True'. When 'False' is returned, do not
662+-- fire, and permanently stop firing, even if 'True' values are encountered
663+-- later.
664+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)
665+takeWhileE f e = do
666+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a
667+ then Right a
668+ else Left never
669+ be <- hold e eFalse
670+ let e' = switch be
671+ return eTrue
672+
673+-- | Split the supplied 'Event' into two individual 'Event's occuring at the
674+-- same time with the respective values from the tuple.
675+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
676+splitE e = (fmap fst e, fmap snd e)
677+
678+-- | Print the supplied 'String' and the value of the 'Event' on each
679+-- occurence. This should /only/ be used for debugging.
680+--
681+-- Note: As with Debug.Trace.trace, the message will only be printed if the
682+-- 'Event' is actually used.
683+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
684+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
685+
686+-- | Print the output of the supplied function on each occurence of the
687+-- 'Event'. This should /only/ be used for debugging.
688+--
689+-- Note: As with Debug.Trace.trace, the message will only be printed if the
690+-- 'Event' is actually used.
691+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
692+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
693+
694+instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
695+ (<>) = alignWith (mergeThese (<>))
696+ sconcat = fmap sconcat . mergeList . toList
697+#if MIN_VERSION_semigroups(0,17,0)
698+ stimes n = fmap $ stimes n
699+#else
700+ times1p n = fmap $ times1p n
701+#endif
702+
703+instance (Semigroup a, Reflex t) => Monoid (Event t a) where
704+ mempty = never
705+ mappend = (<>)
706+ mconcat = fmap sconcat . mergeList
707+
708+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
709+-- list occurs. If multiple occur at the same time they are folded from the left
710+-- with the given function.
711+{-# INLINE mergeWith #-}
712+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
713+mergeWith = mergeWith' id
714+
715+{-# INLINE mergeWith' #-}
716+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
717+mergeWith' f g es = fmap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)
718+ . merge
719+ . DMap.fromDistinctAscList
720+ . map (\(k, v) -> Const2 k :=> v)
721+ $ zip [0 :: Int ..] es
722+
723+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
724+-- list occurs. If multiple occur at the same time the value is the value of the
725+-- leftmost event.
726+{-# INLINE leftmost #-}
727+leftmost :: Reflex t => [Event t a] -> Event t a
728+leftmost = mergeWith const
729+
730+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
731+-- list occurs and has a list of the values of all 'Event's occuring at that
732+-- time.
733+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
734+mergeList [] = never
735+mergeList es = mergeWithFoldCheap' id es
736+
737+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
738+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
739+
740+-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
741+-- occurs if at least one of them occurs and has a map of values of all 'Event's
742+-- occuring at that time.
743+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
744+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
745+
746+-- | Create a merge whose parents can change over time
747+mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
748+mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
749+
750+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
751+mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)
752+mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)
753+
754+-- | Split the event into separate events for 'Left' and 'Right' values.
755+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)
756+fanEither e =
757+ let justLeft = either Just (const Nothing)
758+ justRight = either (const Nothing) Just
759+ in (fmapMaybe justLeft e, fmapMaybe justRight e)
760+
761+-- | Split the event into separate events for 'This' and 'That' values,
762+-- allowing them to fire simultaneously when the input value is 'These'.
763+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)
764+fanThese e =
765+ let this (This x) = Just x
766+ this (These x _) = Just x
767+ this _ = Nothing
768+ that (That y) = Just y
769+ that (These _ y) = Just y
770+ that _ = Nothing
771+ in (fmapMaybe this e, fmapMaybe that e)
772+
773+-- | Split the event into an 'EventSelector' that allows efficient selection of
774+-- the individual 'Event's.
775+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
776+fanMap = fan . fmap mapToDMap
777+
778+-- | Switches to the new event whenever it receives one. Whenever a new event
779+-- is provided, if it is firing, its value will be the resulting event's value;
780+-- if it is not firing, but the old one is, the old one's value will be used.
781+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
782+switchPromptly ea0 eea = do
783+ bea <- hold ea0 eea
784+ let eLag = switch bea
785+ eCoincidences = coincidence eea
786+ return $ leftmost [eCoincidences, eLag]
787+
788+-- | 'switch'es to a new event whenever it receives one. At the moment of
789+-- switching, the old event will be ignored if it fires, and the new one will be
790+-- used if it fires; this is the opposite of 'switch', which will use only the
791+-- old value.
792+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
793+switchPromptOnly e0 e' = do
794+ eLag <- switch <$> hold e0 e'
795+ return $ coincidence $ leftmost [e', eLag <$ eLag]
796+
797+instance Reflex t => Align (Event t) where
798+ nil = never
799+ align = alignEventWithMaybe Just
800+
801+-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
802+-- the 'Behavior' is true at the time of occurence.
803+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
804+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
805+
806+-- | Create a new behavior given a starting behavior and switch to a the behvior
807+-- carried by the event when it fires.
808+switcher :: (Reflex t, MonadHold t m)
809+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
810+switcher b eb = pull . (sample <=< sample) <$> hold b eb
811+
812+-- | Combine two 'Dynamic's. The result will change whenever either (or both)
813+-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.
814+zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)
815+zipDyn = zipDynWith (,)
816+
817+-- | Combine two 'Dynamic's with a combining function. The result will change
818+-- whenever either (or both) input 'Dynamic' changes.
819+-- More efficient than liftA2.
820+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
821+zipDynWith f da db =
822+ let eab = align (updated da) (updated db)
823+ ec = flip push eab $ \o -> do
824+ (a, b) <- case o of
825+ This a -> do
826+ b <- sample $ current db
827+ return (a, b)
828+ That b -> do
829+ a <- sample $ current da
830+ return (a, b)
831+ These a b -> return (a, b)
832+ return $ Just $ f a b
833+ in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
834+
835+instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
836+ mconcat = distributeListOverDynWith mconcat
837+ mempty = constDyn mempty
838+ mappend = zipDynWith mappend
839+
840+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
841+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
842+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.
843+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
844+distributeDMapOverDynPure dm = case DMap.toList dm of
845+ [] -> constDyn DMap.empty
846+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
847+ _ ->
848+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
849+ edmPre = merge $ DMap.map updated dm
850+ result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
851+ olds <- sample $ current result
852+ return $ DMap.unionWithKey (\_ _ new -> new) olds news
853+ in result
854+
855+-- | Convert a list of 'Dynamic's into a 'Dynamic' list.
856+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
857+distributeListOverDyn = distributeListOverDynWith id
858+
859+-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
860+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b
861+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
862+
863+-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
864+-- unless the second supplied 'Event' occurs simultaneously.
865+difference :: Reflex t => Event t a -> Event t b -> Event t a
866+difference = alignEventWithMaybe $ \case
867+ This a -> Just a
868+ _ -> Nothing
869+
870+alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c
871+alignEventWithMaybe f ea eb =
872+ fmapMaybe (f <=< dmapToThese)
873+ $ merge
874+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
875+
876+
877+--------------------------------------------------------------------------------
878+-- Accumulator
879+--------------------------------------------------------------------------------
880+
881+-- | An 'Accumulator' type can be built by accumulating occurrences of an
882+-- 'Event'.
883+class Reflex t => Accumulator t f | f -> t where
884+ accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
885+ accum f = accumMaybe $ \v o -> Just $ f v o
886+ accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
887+ accumM f = accumMaybeM $ \v o -> Just <$> f v o
888+ accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
889+ accumMaybe f = accumMaybeM $ \v o -> return $ f v o
890+ accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
891+ mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
892+ mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
893+ mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
894+ mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
895+ mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
896+ mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
897+ mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
898+
899+-- | Accumulate occurrences of an 'Event', producing an output occurrence each
900+-- time. Discard the underlying 'Accumulator'.
901+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)
902+mapAccum_ f z e = do
903+ (_ :: Behavior t a, result) <- mapAccum f z e
904+ return result
905+
906+-- | Accumulate occurrences of an 'Event', possibly producing an output
907+-- occurrence each time. Discard the underlying 'Accumulator'.
908+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)
909+mapAccumMaybe_ f z e = do
910+ (_ :: Behavior t a, result) <- mapAccumMaybe f z e
911+ return result
912+
913+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing
914+-- an output occurrence each time. Discard the underlying 'Accumulator'.
915+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)
916+mapAccumM_ f z e = do
917+ (_ :: Behavior t a, result) <- mapAccumM f z e
918+ return result
919+
920+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly
921+-- producing an output occurrence each time. Discard the underlying
922+-- 'Accumulator'.
923+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)
924+mapAccumMaybeM_ f z e = do
925+ (_ :: Behavior t a, result) <- mapAccumMaybeM f z e
926+ return result
927+
928+instance Reflex t => Accumulator t (Dynamic t) where
929+ accumMaybeM f z e = do
930+ rec let e' = flip push e $ \o -> do
931+ v <- sample $ current d'
932+ f v o
933+ d' <- holdDyn z e'
934+ return d'
935+ mapAccumMaybeM f z e = do
936+ rec let e' = flip push e $ \o -> do
937+ v <- sample $ current d'
938+ result <- f v o
939+ return $ case result of
940+ (Nothing, Nothing) -> Nothing
941+ _ -> Just result
942+ d' <- holdDyn z $ fmapMaybe fst e'
943+ return (d', fmapMaybe snd e')
944+
945+instance Reflex t => Accumulator t (Behavior t) where
946+ accumMaybeM f z e = current <$> accumMaybeM f z e
947+ mapAccumMaybeM f z e = first current <$> mapAccumMaybeM f z e
948+
949+instance Reflex t => Accumulator t (Event t) where
950+ accumMaybeM f z e = updated <$> accumMaybeM f z e
951+ mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
952+
953+-- | Create a new 'Event' by combining each occurence with the next value of the
954+-- list using the supplied function. If the list runs out of items, all
955+-- subsequent 'Event' occurrences will be ignored.
956+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
957+zipListWithEvent f l e = do
958+ let f' a b = case a of
959+ h:t -> (Just t, Just $ f h b)
960+ _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
961+ mapAccumMaybe_ f' l e
962+
963+-- | Assign a number to each occurence of the given 'Event', starting from 0
964+numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))
965+numberOccurrences = numberOccurrencesFrom 0
966+
967+-- | Assign a number to each occurence of the given 'Event'
968+numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))
969+numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))
970+
971+-- | This is used to sample the value of a 'Behavior' using an 'Event'.
972+--
973+-- The '<@>' operator is intended to be used in conjunction with
974+-- the 'Applicative' instance for 'Behavior'.
975+--
976+-- This is useful when we want to combine the values of one 'Event' and
977+-- the value of several 'Behavior's at the time the 'Event' is firing.
978+--
979+-- If we have:
980+--
981+-- > f :: a -> b -> c -> d
982+-- > b1 :: Behavior t a
983+-- > b2 :: Behavior t b
984+-- > e :: Event t c
985+--
986+-- then we can do:
987+--
988+-- > f <$> b1 <*> b2 <@> e :: Event t d
989+--
990+-- in order to apply the function 'f' to the relevant values.
991+--
992+-- The alternative would be something like:
993+--
994+-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d
995+--
996+-- or a variation involing a custom data type to hold the combination of
997+-- 'Behavior's even when that combination might only ever be used by 'f'.
998+--
999+-- A more suggestive example might be:
1000+--
1001+-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)
1002+--
1003+(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b
1004+(<@>) b = push $ \x -> do
1005+ f <- sample b
1006+ return . Just . f $ x
1007+infixl 4 <@>
1008+
1009+-- | An version of '<@>' that does not use the value of the 'Event'.
1010+--
1011+-- Alternatively, it is 'tag' in operator form.
1012+--
1013+-- This is useful when we want to combine the values of several
1014+-- 'Behavior's at particular points in time using an 'Applicative'
1015+-- style syntax.
1016+--
1017+-- If we have:
1018+--
1019+-- > g :: a -> b -> d
1020+-- > b1 :: Behavior t a
1021+-- > b2 :: Behavior t b
1022+-- > e :: Event t c
1023+--
1024+-- where 'e' is firing at the points in time of interest.
1025+--
1026+-- Then we can use '<@':
1027+--
1028+-- > g <$> b1 <*> b2 <@ e :: Event t d
1029+--
1030+-- to combine the values of 'b1' and 'b2' at each of those points of time,
1031+-- with the function 'g' being used to combine the values.
1032+--
1033+-- This is the same as '<@>' except that the 'Event' is being used only
1034+-- to act as a trigger.
1035+(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b
1036+(<@) = tag
1037+infixl 4 <@
1038+
1039+-- | A 'Monad' that supports adjustment over time. After an action has been
1040+-- run, if the given events fire, it will adjust itself so that its net effect
1041+-- is as though it had originally been run with the new value. Note that there
1042+-- is some issue here with persistent side-effects: obviously, IO (and some
1043+-- other side-effects) cannot be undone, so it is up to the instance implementer
1044+-- to determine what the best meaning for this class is in such cases.
1045+class (Reflex t, Monad m) => MonadAdjust t m | m -> t where
1046+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
1047+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
1048+ 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'))
1049+ 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'))
1050+
1051+instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where
1052+ runWithReplace a0 a' = do
1053+ r <- ask
1054+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
1055+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
1056+ r <- ask
1057+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1058+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
1059+ r <- ask
1060+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1061+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
1062+ r <- ask
1063+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
1064+
1065+sequenceDMapWithAdjust :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
1066+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
1067+
1068+sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
1069+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
1070+
1071+mapMapWithAdjustWithMove :: forall t m k v v'. (MonadAdjust t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))
1072+mapMapWithAdjustWithMove f m0 m' = do
1073+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
1074+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
1075+
1076+------------------
1077+-- Cheap Functions
1078+------------------
1079+
1080+{-# INLINE pushAlwaysCheap #-}
1081+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
1082+pushAlwaysCheap f = pushCheap (fmap Just . f)
1083+
1084+{-# INLINE fmapMaybeCheap #-}
1085+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1086+fmapMaybeCheap f = pushCheap $ return . f
1087+
1088+{-# INLINE fforMaybeCheap #-}
1089+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b
1090+fforMaybeCheap = flip fmapMaybeCheap
1091+
1092+{-# INLINE fforCheap #-}
1093+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b
1094+fforCheap = flip fmapCheap
1095+
1096+{-# INLINE fmapCheap #-}
1097+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b
1098+fmapCheap f = pushCheap $ return . Just . f
1099+
1100+{-# INLINE tagCheap #-}
1101+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1102+tagCheap b = pushAlwaysCheap $ \_ -> sample b
1103+
1104+{-# INLINE mergeWithCheap #-}
1105+mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1106+mergeWithCheap = mergeWithCheap' id
1107+
1108+{-# INLINE mergeWithCheap' #-}
1109+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
1110+mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f
1111+
1112+{-# INLINE mergeWithFoldCheap' #-}
1113+mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b
1114+mergeWithFoldCheap' f es =
1115+ fmapCheap (f . (\(h : t) -> h :| t) . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)
1116+ . merge
1117+ . DMap.fromDistinctAscList
1118+ . map (\(k, v) -> Const2 k :=> v)
1119+ $ zip [0 :: Int ..] es
1120+
1121+--------------------------------------------------------------------------------
1122+-- Deprecated functions
1123+--------------------------------------------------------------------------------
1124+
1125+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's
1126+-- occurs. If both occur at the same time they are combined using 'mappend'.
1127+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}
1128+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
1129+appendEvents = alignWith $ mergeThese mappend
1130+
1131+-- | Alias for 'headE'
1132+{-# DEPRECATED onceE "Use 'headE' instead" #-}
1133+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
1134+onceE = headE
1135+
1136+-- | Run both sides of a 'These' monadically, combining the results.
1137+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
1138+#ifdef USE_TEMPLATE_HASKELL
1139+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}
1140+#endif
1141+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
1142+sequenceThese t = case t of
1143+ This ma -> fmap This ma
1144+ These ma mb -> liftM2 These ma mb
1145+ That mb -> fmap That mb
src/Reflex/Dynamic.hsnew file+658
@@ -0,0 +1,658 @@
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+ , constDyn
29+ , count
30+ , toggle
31+ , switchPromptlyDyn
32+ , tagPromptlyDyn
33+ , attachPromptlyDyn
34+ , attachPromptlyDynWith
35+ , attachPromptlyDynWithMaybe
36+ , maybeDyn
37+ , scanDyn
38+ , scanDynMaybe
39+ , holdUniqDyn
40+ , holdUniqDynBy
41+ , improvingMaybe
42+ , foldDyn
43+ , foldDynM
44+ , foldDynMaybe
45+ , foldDynMaybeM
46+ , joinDynThroughMap
47+ , traceDyn
48+ , traceDynWith
49+ , splitDynPure
50+ , distributeMapOverDynPure
51+ , distributeDMapOverDynPure
52+ , distributeListOverDynPure
53+ , Demux
54+ , demux
55+ , demuxed
56+ -- Things that probably aren't very useful:
57+ , HList (..)
58+ , FHList (..)
59+ , collectDynPure
60+ , RebuildSortedHList (..)
61+ , IsHList (..)
62+ , AllAreFunctors (..)
63+ , HListPtr (..)
64+ , distributeFHListOverDynPure
65+ -- Unsafe
66+ , unsafeDynamic
67+ -- * Deprecated functions
68+ , apDyn
69+ , attachDyn
70+ , attachDynWith
71+ , attachDynWithMaybe
72+ , collectDyn
73+ , combineDyn
74+ , distributeDMapOverDyn
75+ , distributeFHListOverDyn
76+ , forDyn
77+ , forDynM
78+ , getDemuxed
79+ , joinDyn
80+ , mapDyn
81+ , mapDynM
82+ , mconcatDyn
83+ , nubDyn
84+ , splitDyn
85+ , tagDyn
86+ , uniqDyn
87+ , uniqDynBy
88+ ) where
89+
90+import Data.Functor.Misc
91+import Reflex.Class
92+
93+import Control.Applicative ((<*>))
94+import Control.Monad
95+import Control.Monad.Fix
96+import Control.Monad.Identity
97+import Data.Align
98+import Data.Dependent.Map (DMap)
99+import qualified Data.Dependent.Map as DMap
100+import Data.Dependent.Sum (DSum (..))
101+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
102+import Data.Map (Map)
103+import Data.Maybe
104+import Data.Monoid
105+import Data.These
106+
107+import Debug.Trace
108+
109+-- | Create a new 'Dynamic' that only signals changes if the values actually
110+-- changed.
111+holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)
112+holdUniqDyn = holdUniqDynBy (==)
113+
114+-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'
115+-- changes and the given function returns 'False' when given both the old and
116+-- the new values.
117+holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)
118+holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)
119+
120+-- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing)
121+improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))
122+improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)
123+
124+-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'. This
125+-- function does not force its input 'Dynamic' until the output 'Dynamic' is
126+-- forced.
127+scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)
128+scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b)
129+
130+-- | Like 'scanDyn', but the the accumulator function may decline to update the
131+-- result 'Dynamic''s value.
132+scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)
133+scanDynMaybe z f d = do
134+ rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do
135+ b <- sample $ current d'
136+ return $ f a b
137+ return d'
138+
139+-- | Create a 'Dynamic' using the initial value and change it each time the
140+-- 'Event' occurs using a folding function on the previous value and the value
141+-- of the 'Event'.
142+foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
143+foldDyn = accum . flip
144+
145+-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it
146+-- can 'sample' existing 'Behaviors' and 'hold' new ones.
147+foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
148+foldDynM = accumM . flip
149+
150+-- | Create a 'Dynamic' using the provided initial value and change it each time
151+-- the provided 'Event' occurs, using a function to combine the old value with
152+-- the 'Event''s value. If the function returns 'Nothing', the value is not
153+-- changed; this is distinct from returning 'Just' the old value, since the
154+-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire
155+-- in the 'Nothing' case.
156+foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
157+foldDynMaybe = accumMaybe . flip
158+
159+-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it
160+-- can 'sample' existing 'Behaviors' and 'hold' new ones.
161+foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
162+foldDynMaybeM = accumMaybeM . flip
163+
164+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
165+count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
166+count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
167+
168+-- | Create a new 'Dynamic' using the initial value that flips its
169+-- value every time the 'Event' occurs.
170+toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
171+toggle = foldDyn (const not)
172+
173+-- | Switches to the new 'Event' whenever it receives one. Switching occurs
174+-- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the
175+-- old and new inner Events fire simultaneously, the output will fire with the
176+-- value of the *new* 'Event'.
177+switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
178+switchPromptlyDyn de =
179+ let eLag = switch $ current de
180+ eCoincidences = coincidence $ updated de
181+ in leftmost [eCoincidences, eLag]
182+
183+-- | Split a 'Dynamic' pair into a pair of 'Dynamic's
184+splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)
185+splitDynPure d = (fmap fst d, fmap snd d)
186+
187+-- | Convert a 'Map' with 'Dynamic' elements into a 'Dynamic' of a 'Map' with
188+-- non-'Dynamic' elements.
189+distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
190+distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
191+
192+-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
193+-- non-'Dynamic' elements, preserving the order of the elements.
194+distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]
195+distributeListOverDynPure =
196+ fmap (map fromDSum . DMap.toAscList) .
197+ distributeDMapOverDynPure .
198+ DMap.fromDistinctAscList .
199+ zipWith toDSum [0..]
200+ where
201+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)
202+ toDSum k v = Const2 k :=> v
203+ fromDSum :: DSum (Const2 Int a) Identity -> a
204+ fromDSum (Const2 _ :=> Identity v) = v
205+
206+--TODO: Generalize this to functors other than Maps
207+-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
208+-- with the current values of the 'Dynamic's in a map.
209+joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
210+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure
211+
212+-- | Print the value of the 'Dynamic' when it is first read and on each
213+-- subsequent change that is observed (as traceEvent), prefixed with the
214+-- provided string. This should /only/ be used for debugging.
215+--
216+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
217+-- else in the system is depending on it.
218+traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
219+traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
220+
221+-- | Print the result of applying the provided function to the value
222+-- of the 'Dynamic' when it is first read and on each subsequent change
223+-- that is observed (as traceEvent). This should /only/ be used for
224+-- debugging.
225+--
226+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
227+-- else in the system is depending on it.
228+traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
229+traceDynWith f d =
230+ let e' = traceEventWith f $ updated d
231+ getV0 = do
232+ x <- sample $ current d
233+ trace (f x) $ return x
234+ in unsafeBuildDynamic getV0 e'
235+
236+-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
237+-- each time the 'Event' occurs.
238+--
239+-- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing
240+-- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d`
241+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
242+-- will be used, since the 'Behavior' won't be updated until the end of the frame.
243+-- Additionally, this means that the output 'Event' may not be used to directly change
244+-- the input 'Dynamic', because that would mean its value depends on itself. When creating
245+-- cyclic data flows, generally `tag (current d) e` is preferred.
246+tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
247+tagPromptlyDyn = attachPromptlyDynWith const
248+
249+-- | Attach the current value of the 'Dynamic' to the value of the
250+-- 'Event' each time it occurs.
251+--
252+-- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details.
253+attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
254+attachPromptlyDyn = attachPromptlyDynWith (,)
255+
256+-- | Combine the current value of the 'Dynamic' with the value of the
257+-- 'Event' each time it occurs.
258+--
259+-- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details.
260+attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
261+attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b
262+
263+-- | Create a new 'Event' by combining the value at each occurence with the
264+-- current value of the 'Dynamic' value and possibly filtering if the combining
265+-- function returns 'Nothing'.
266+--
267+-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f
268+-- (current d)`. See 'tagPromptlyDyn' for details.
269+attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
270+attachPromptlyDynWithMaybe f d e =
271+ let e' = attach (current d) e
272+ in fforMaybe (align e' $ updated d) $ \case
273+ This (a, b) -> f a b -- Only the tagging event is firing, so use that
274+ These (_, b) a -> f a b -- Both events are firing, so use the newer value
275+ That _ -> Nothing -- The tagging event isn't firing, so don't fire
276+
277+-- | Factor a @Dynamic t (Maybe a)@ into a @Dynamic t (Maybe (Dynamic t a))@,
278+-- such that the outer 'Dynamic' is updated only when the 'Maybe''s constructor
279+-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor
280+-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track
281+-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the
282+-- existing inner 'Dynamic' will become constant, and will not change when the
283+-- outer constructor changes back to 'Nothing'.
284+maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))
285+maybeDyn d = do
286+ ma <- sample $ current d
287+ let inner :: forall m'. (MonadFix m', MonadHold t m') => a -> m' (Dynamic t a)
288+ inner a = holdDyn a . fmapMaybe id =<< takeWhileE isJust (updated d)
289+ mInner0 :: Maybe (Dynamic t a) <- mapM inner ma
290+ rec result <- holdDyn mInner0 $ flip push (updated d) $ \new -> do
291+ old <- sample $ current d
292+ if isJust old == isJust new then return Nothing else Just <$> mapM inner new
293+ return result
294+
295+--------------------------------------------------------------------------------
296+-- Demux
297+--------------------------------------------------------------------------------
298+
299+-- | Represents a time changing value together with an 'EventSelector' that can
300+-- efficiently detect when the underlying 'Dynamic' has a particular value.
301+-- This is useful for representing data like the current selection of a long
302+-- list.
303+--
304+-- Semantically,
305+--
306+-- > demuxed (demux d) k === fmap (== k) d
307+--
308+-- However, the when getDemuxed is used multiple times, the complexity is only
309+-- /O(log(n))/, rather than /O(n)/ for fmap.
310+data Demux t k = Demux { demuxValue :: Behavior t k
311+ , demuxSelector :: EventSelector t (Const2 k Bool)
312+ }
313+
314+-- | Demultiplex an input value to a 'Demux' with many outputs. At any given
315+-- time, whichever output is indicated by the given 'Dynamic' will be 'True'.
316+demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
317+demux k = Demux (current k)
318+ (fan $ attachWith (\k0 k1 -> if k0 == k1
319+ then DMap.empty
320+ else DMap.fromList [Const2 k0 :=> Identity False,
321+ Const2 k1 :=> Identity True])
322+ (current k) (updated k))
323+
324+-- | Select a particular output of the 'Demux'; this is equivalent to (but much
325+-- faster than) mapping over the original 'Dynamic' and checking whether it is
326+-- equal to the given key.
327+demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
328+demuxed d k =
329+ let e = select (demuxSelector d) (Const2 k)
330+ in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
331+
332+--------------------------------------------------------------------------------
333+-- collectDyn
334+--------------------------------------------------------------------------------
335+
336+--TODO: This whole section is badly in need of cleanup
337+
338+-- | A heterogeneous list whose type and length are fixed statically. This is
339+-- reproduced from the 'HList' package due to integration issues, and because
340+-- very little other functionality from that library is needed.
341+data HList (l::[*]) where
342+ HNil :: HList '[]
343+ HCons :: e -> HList l -> HList (e ': l)
344+
345+infixr 2 `HCons`
346+
347+type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
348+type instance HRevApp '[] l = l
349+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
350+
351+hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
352+hRevApp HNil l = l
353+hRevApp (HCons x l) l' = hRevApp l (HCons x l')
354+
355+hReverse :: HList l -> HList (HRevApp l '[])
356+hReverse l = hRevApp l HNil
357+
358+hBuild :: (HBuild' '[] r) => r
359+hBuild = hBuild' HNil
360+
361+class HBuild' l r where
362+ hBuild' :: HList l -> r
363+
364+instance (l' ~ HRevApp l '[])
365+ => HBuild' l (HList l') where
366+ hBuild' = hReverse
367+
368+instance HBuild' (a ': l) r
369+ => HBuild' l (a->r) where
370+ hBuild' l x = hBuild' (HCons x l)
371+
372+-- | Like 'HList', but with a functor wrapping each element.
373+data FHList f l where
374+ FHNil :: FHList f '[]
375+ FHCons :: f e -> FHList f l -> FHList f (e ': l)
376+
377+instance GEq (HListPtr l) where
378+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
379+ geqToEq _ = id
380+ geqUnify HHeadPtr HHeadPtr _ same = same
381+ geqUnify (HTailPtr a) (HTailPtr b) different same = geqUnify a b different same
382+ geqUnify _ _ different _ = different
383+#endif
384+ HHeadPtr `geq` HHeadPtr = Just Refl
385+ HHeadPtr `geq` HTailPtr _ = Nothing
386+ HTailPtr _ `geq` HHeadPtr = Nothing
387+ HTailPtr a `geq` HTailPtr b = a `geq` b
388+
389+instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
390+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
391+ gcompareToOrd _ = id
392+#endif
393+ HHeadPtr `gcompare` HHeadPtr = GEQ
394+ HHeadPtr `gcompare` HTailPtr _ = GLT
395+ HTailPtr _ `gcompare` HHeadPtr = GGT
396+ HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
397+
398+-- | A typed index into a typed heterogeneous list.
399+data HListPtr l a where
400+ HHeadPtr :: HListPtr (h ': t) h
401+ HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
402+
403+deriving instance Eq (HListPtr l a)
404+deriving instance Ord (HListPtr l a)
405+
406+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
407+fhlistToDMap = DMap.fromList . go
408+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
409+ go = \case
410+ FHNil -> []
411+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t)
412+
413+-- | This class allows 'HList's and 'FHlist's to be built from regular lists;
414+-- they must be contiguous and sorted.
415+class RebuildSortedHList l where
416+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
417+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
418+
419+instance RebuildSortedHList '[] where
420+ rebuildSortedFHList l = case l of
421+ [] -> FHNil
422+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
423+ rebuildSortedHList l = case l of
424+ [] -> HNil
425+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
426+
427+instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
428+ rebuildSortedFHList l = case l of
429+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
430+ _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
431+ rebuildSortedHList l = case l of
432+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
433+ _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
434+
435+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
436+dmapToHList = rebuildSortedHList . DMap.toList
437+
438+-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
439+-- single 'Dynamic' whose value represents the current values of all of the
440+-- input 'Dynamic's.
441+distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
442+distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
443+
444+-- | Indicates that all elements in a type-level list are applications of the
445+-- same functor.
446+class AllAreFunctors (f :: a -> *) (l :: [a]) where
447+ type FunctorList f l :: [*]
448+ toFHList :: HList (FunctorList f l) -> FHList f l
449+ fromFHList :: FHList f l -> HList (FunctorList f l)
450+
451+instance AllAreFunctors f '[] where
452+ type FunctorList f '[] = '[]
453+ toFHList l = case l of
454+ HNil -> FHNil
455+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
456+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
457+#endif
458+ fromFHList FHNil = HNil
459+
460+instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
461+ type FunctorList f (h ': t) = f h ': FunctorList f t
462+ toFHList l = case l of
463+ a `HCons` b -> a `FHCons` toFHList b
464+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
465+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
466+#endif
467+ fromFHList (a `FHCons` b) = a `HCons` fromFHList b
468+
469+-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
470+-- single 'Dynamic' whose value represents all the current values of the input's
471+-- consitutent 'Dynamic's.
472+collectDynPure :: ( RebuildSortedHList (HListElems b)
473+ , IsHList a, IsHList b
474+ , AllAreFunctors (Dynamic t) (HListElems b)
475+ , Reflex t
476+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
477+ ) => a -> Dynamic t b
478+collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds
479+
480+-- | Poor man's 'Generic's for product types only.
481+class IsHList a where
482+ type HListElems a :: [*]
483+ toHList :: a -> HList (HListElems a)
484+ fromHList :: HList (HListElems a) -> a
485+
486+instance IsHList (a, b) where
487+ type HListElems (a, b) = [a, b]
488+ toHList (a, b) = hBuild a b
489+ fromHList l = case l of
490+ a `HCons` b `HCons` HNil -> (a, b)
491+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
492+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
493+#endif
494+
495+instance IsHList (a, b, c, d) where
496+ type HListElems (a, b, c, d) = [a, b, c, d]
497+ toHList (a, b, c, d) = hBuild a b c d
498+ fromHList l = case l of
499+ a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
500+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
501+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
502+#endif
503+
504+instance IsHList (a, b, c, d, e, f) where
505+ type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
506+ toHList (a, b, c, d, e, f) = hBuild a b c d e f
507+ fromHList l = case l of
508+ a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
509+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
510+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
511+#endif
512+
513+--------------------------------------------------------------------------------
514+-- Deprecated functions
515+--------------------------------------------------------------------------------
516+
517+-- | Map a function over a 'Dynamic'.
518+{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}
519+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
520+mapDyn f = return . fmap f
521+
522+-- | Map a sampling function over a 'Dynamic'. The sampling function will use the input 'Dynamic''s 'current' 'Behavior' until the first time its 'updated' 'Event' fires, at which point it will be invoked only once each time the 'Event' fires.
523+{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-}
524+mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)
525+mapDynM f d = do
526+ let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d
527+ eb' = fmap constant e'
528+ v0 = pull $ f =<< sample (current d)
529+ bb' :: Behavior t (Behavior t b) <- hold v0 eb'
530+ let b' = pull $ sample =<< sample bb'
531+ return $ unsafeDynamic b' e'
532+
533+-- | Flipped version of 'mapDyn'.
534+{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}
535+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
536+forDyn a = return . ffor a
537+
538+-- | Flipped version of 'mapDynM'
539+{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-}
540+forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b)
541+forDynM d f = mapDynM f d
542+
543+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value
544+-- of the tuple.
545+{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}
546+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
547+splitDyn = return . splitDynPure
548+
549+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
550+{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}
551+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
552+mconcatDyn = return . mconcat
553+
554+-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.
555+{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}
556+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
557+distributeDMapOverDyn = return . distributeDMapOverDynPure
558+
559+-- | Merge two 'Dynamic's into a new one using the provided function. The new
560+-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes
561+-- its value.
562+{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}
563+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
564+combineDyn f a b = return $ zipDynWith f a b
565+
566+-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
567+--
568+-- > do
569+-- > person <- Person `mapDyn` dynFirstName
570+-- > `apDyn` dynListName
571+-- > `apDyn` dynAge
572+-- > `apDyn` dynAddress
573+{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-}
574+#ifdef USE_TEMPLATE_HASKELL
575+{-# ANN apDyn "HLint: ignore Use fmap" #-}
576+#endif
577+apDyn :: forall t m a b. (Reflex t, Monad m)
578+ => m (Dynamic t (a -> b))
579+ -> Dynamic t a
580+ -> m (Dynamic t b)
581+apDyn m a = fmap (<*> a) m
582+
583+--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
584+-- | This function no longer needs to be monadic, so it has been replaced by
585+-- 'demuxed', which is pure.
586+{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}
587+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
588+getDemuxed d = return . demuxed d
589+
590+-- | This function no longer needs to be monadic, so it has been replaced by
591+-- 'distributeFHListOverDynPure', which is pure.
592+{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}
593+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
594+distributeFHListOverDyn = return . distributeFHListOverDynPure
595+
596+-- | This function no longer needs to be monadic, so it has been replaced by
597+-- 'collectDynPure', which is pure.
598+{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}
599+collectDyn :: ( RebuildSortedHList (HListElems b)
600+ , IsHList a, IsHList b
601+ , AllAreFunctors (Dynamic t) (HListElems b)
602+ , Reflex t, Monad m
603+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
604+ ) => a -> m (Dynamic t b)
605+collectDyn = return . collectDynPure
606+
607+-- | This function has been renamed to 'tagPromptlyDyn' to clarify its
608+-- semantics.
609+{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}
610+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
611+tagDyn = tagPromptlyDyn
612+
613+-- | This function has been renamed to 'attachPromptlyDyn' to clarify its
614+-- semantics.
615+{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}
616+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
617+attachDyn = attachPromptlyDyn
618+
619+-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its
620+-- semantics.
621+{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}
622+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
623+attachDynWith = attachPromptlyDynWith
624+
625+-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify
626+-- its semantics.
627+{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}
628+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
629+attachDynWithMaybe = attachPromptlyDynWithMaybe
630+
631+-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s
632+-- current value will always be equal to the current value's current value, and
633+-- will change whenever either the inner or the outer (or both) values change.
634+{-# DEPRECATED joinDyn "Use 'join' instead" #-}
635+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a
636+joinDyn = join
637+
638+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
639+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
640+-- circumstances. Also, note that, unlike 'nub', this function does not prevent
641+-- all recurrences of a value, only consecutive recurrences.
642+{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
643+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
644+nubDyn = uniqDyn
645+
646+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
647+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
648+-- circumstances.
649+{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
650+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
651+uniqDyn = uniqDynBy (==)
652+
653+-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.
654+{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
655+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a
656+uniqDynBy eq d =
657+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)
658+ in unsafeDynamic (current d) e'
src/Reflex/Dynamic/TH.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 push (updated d) $ \new -> do --TODO: It would be very nice if we had an uncached push here
35+ old <- sample $ current d --TODO: Is it better to sample ourselves here?
36+ return $ unsafeJustChanged old new
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 <- accumMaybeM f' z e
85+ return $ UniqDynamic d
86+ mapAccumMaybeM f z e = do
87+ let f' old change = do
88+ (mNew, output) <- f old change
89+ return (unsafeJustChanged old =<< mNew, output)
90+ (d, out) <- mapAccumMaybeM 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+192
@@ -0,0 +1,192 @@
1+-- | This module defines 'MonadDynamicWriter' and 'DynamicWriterT', its standard
2+-- implementation.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE LambdaCase #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#ifdef USE_REFLEX_OPTIMIZER
15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16+#endif
17+module Reflex.DynamicWriter
18+ ( MonadDynamicWriter (..)
19+ , DynamicWriterT (..)
20+ , runDynamicWriterT
21+ , withDynamicWriterT
22+ ) where
23+
24+import Control.Monad.Exception
25+import Control.Monad.Identity
26+import Control.Monad.IO.Class
27+import Control.Monad.Reader
28+import Control.Monad.Ref
29+import Control.Monad.State.Strict
30+import Data.Align
31+import Data.Dependent.Map (DMap)
32+import qualified Data.Dependent.Map as DMap
33+import Data.Functor.Misc
34+import Data.Map (Map)
35+import qualified Data.Map as Map
36+import Data.Semigroup
37+import Data.Some (Some)
38+import Data.These
39+import Reflex.Class
40+import Reflex.Host.Class
41+import qualified Reflex.Patch.MapWithMove as MapWithMove
42+import Reflex.PerformEvent.Class
43+import Reflex.PostBuild.Class
44+import Reflex.Requester.Class
45+import Reflex.TriggerEvent.Class
46+
47+instance MonadTrans (DynamicWriterT t w) where
48+ lift = DynamicWriterT . lift
49+
50+mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')
51+mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
52+
53+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
54+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
55+ where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
56+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
57+
58+mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
59+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
60+ where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
61+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
62+ f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
63+ f x = unsafePatchMapWithMove $
64+ let (p, changed) = case x of
65+ This p_ -> (unPatchMapWithMove p_, mempty)
66+ That c -> (mempty, c)
67+ These p_ c -> (unPatchMapWithMove p_, c)
68+ (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
69+ MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
70+ MapWithMove.From_Delete -> return $ MapWithMove.From_Delete
71+ MapWithMove.From_Move k -> case Map.lookup k changed of
72+ Nothing -> return $ MapWithMove.From_Move k
73+ Just v -> do
74+ modify (k:)
75+ return $ MapWithMove.From_Insert v
76+ noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved
77+ in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
78+
79+-- | A basic implementation of 'MonadDynamicWriter'.
80+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
81+
82+instance MonadRef m => MonadRef (DynamicWriterT t w m) where
83+ type Ref (DynamicWriterT t w m) = Ref m
84+ newRef = lift . newRef
85+ readRef = lift . readRef
86+ writeRef r = lift . writeRef r
87+
88+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
89+ atomicModifyRef r = lift . atomicModifyRef r
90+
91+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
92+ newEventWithTrigger = lift . newEventWithTrigger
93+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
94+
95+-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
96+-- along with the result of the action.
97+runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
98+runDynamicWriterT (DynamicWriterT a) = do
99+ (result, ws) <- runStateT a []
100+ return (result, mconcat $ reverse ws)
101+
102+-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
103+-- and combines them monoidally to provide a 'Dynamic' result.
104+class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
105+ tellDyn :: Dynamic t w -> m ()
106+
107+instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
108+ tellDyn w = DynamicWriterT $ modify (w :)
109+
110+instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
111+ ask = lift ask
112+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
113+ reader = lift . reader
114+
115+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
116+ type Performable (DynamicWriterT t w m) = Performable m
117+ performEvent_ = lift . performEvent_
118+ performEvent = lift . performEvent
119+
120+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
121+ newTriggerEvent = lift newTriggerEvent
122+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
123+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
124+
125+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
126+ getPostBuild = lift getPostBuild
127+
128+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
129+ tellDyn = lift . tellDyn
130+
131+instance MonadState s m => MonadState s (DynamicWriterT t w m) where
132+ get = lift get
133+ put = lift . put
134+
135+newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
136+
137+-- | When the execution of a 'DynamicWriterT' action is adjusted using
138+-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to
139+-- match.
140+instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where
141+ runWithReplace a0 a' = do
142+ (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
143+ tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
144+ return (fst result0, fst <$> result')
145+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
146+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
147+
148+traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)
149+ => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
150+ -> DMap k v
151+ -> Event t (p k v)
152+ -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
153+ )
154+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
155+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
156+ -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
157+ -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
158+ -> DMap k v
159+ -> Event t (p k v)
160+ -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
161+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
162+ (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
163+ let getValue (DynamicWriterTLoweredResult (v, _)) = v
164+ getWritten (DynamicWriterTLoweredResult (_, w)) = w
165+ liftedResult0 = DMap.map getValue result0
166+ liftedResult' = ffor result' $ mapPatch getValue
167+ liftedWritten0 :: Map (Some k) (Dynamic t w)
168+ liftedWritten0 = weakenDMapWith getWritten result0
169+ liftedWritten' = ffor result' $ weakenPatchWith getWritten
170+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
171+ i <- holdIncremental liftedWritten0 liftedWritten'
172+ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
173+ return (liftedResult0, liftedResult')
174+
175+-- | Map a function over the output of a 'DynamicWriterT'.
176+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
177+ => (w -> w')
178+ -> DynamicWriterT t w m a
179+ -> DynamicWriterT t w' m a
180+withDynamicWriterT f dw = do
181+ (r, d) <- lift $ do
182+ (r, d) <- runDynamicWriterT dw
183+ let d' = fmap f d
184+ return (r, d')
185+ tellDyn d
186+ return r
187+
188+instance Requester t m => Requester t (DynamicWriterT t w m) where
189+ type Request (DynamicWriterT t w m) = Request m
190+ type Response (DynamicWriterT t w m) = Response m
191+ requesting = lift . requesting
192+ requesting_ = lift . requesting_
src/Reflex/EventWriter.hsnew file+262
@@ -0,0 +1,262 @@
1+-- | This module provides 'EventWriterT', the standard implementation of
2+-- 'EventWriter'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE Rank2Types #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#ifdef USE_REFLEX_OPTIMIZER
15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16+#endif
17+module Reflex.EventWriter
18+ ( EventWriterT (..)
19+ , runEventWriterT
20+ , EventWriter (..)
21+ , runWithReplaceEventWriterTWith
22+ , sequenceDMapWithAdjustEventWriterTWith
23+ ) where
24+
25+import Reflex.Class
26+import Reflex.Host.Class
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
29+import Reflex.Query.Class
30+import Reflex.Requester.Class
31+import Reflex.TriggerEvent.Class
32+
33+import Control.Monad.Exception
34+import Control.Monad.Identity
35+import Control.Monad.Reader
36+import Control.Monad.Ref
37+import Control.Monad.State.Strict
38+import Data.Dependent.Map (DMap, DSum (..))
39+import qualified Data.Dependent.Map as DMap
40+import Data.FastMutableIntMap
41+import Data.Foldable
42+import Data.Functor.Compose
43+import Data.Functor.Misc
44+import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
45+import Data.IntMap.Strict (IntMap)
46+import qualified Data.IntMap.Strict as IntMap
47+import Data.List.NonEmpty (NonEmpty (..))
48+import Data.Map (Map)
49+import Data.Semigroup
50+import Data.Some (Some)
51+import Data.Tuple
52+import Data.Type.Equality
53+
54+import Unsafe.Coerce
55+
56+-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
57+-- and combines them monoidally to provide an 'Event' result.
58+class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
59+ tellEvent :: Event t w -> m ()
60+
61+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
62+newtype TellId w x
63+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
64+ deriving (Show, Eq, Ord, Enum)
65+
66+tellId :: Int -> TellId w w
67+tellId = TellId
68+{-# INLINE tellId #-}
69+
70+tellIdRefl :: TellId w x -> w :~: x
71+tellIdRefl _ = unsafeCoerce Refl
72+
73+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
74+withTellIdRefl tid r = case tellIdRefl tid of
75+ Refl -> r
76+
77+instance GEq (TellId w) where
78+ a `geq` b =
79+ withTellIdRefl a $
80+ withTellIdRefl b $
81+ if a == b
82+ then Just Refl
83+ else Nothing
84+
85+instance GCompare (TellId w) where
86+ a `gcompare` b =
87+ withTellIdRefl a $
88+ withTellIdRefl b $
89+ case a `compare` b of
90+ LT -> GLT
91+ EQ -> GEQ
92+ GT -> GGT
93+
94+data EventWriterState t w = EventWriterState
95+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
96+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
97+ }
98+
99+-- | A basic implementation of 'EventWriter'.
100+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
101+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
102+
103+-- | Run a 'EventWriterT' action.
104+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
105+runEventWriterT (EventWriterT a) = do
106+ (result, requests) <- runStateT a $ EventWriterState (-1) []
107+ let combineResults :: DMap (TellId w) Identity -> w
108+ combineResults = sconcat
109+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
110+ . 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
111+ 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
112+
113+instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
114+ tellEvent w = EventWriterT $ modify $ \old ->
115+ let myId = _eventWriterState_nextId old
116+ in EventWriterState
117+ { _eventWriterState_nextId = pred myId
118+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
119+ }
120+
121+instance EventWriter t w m => EventWriter t w (ReaderT r m) where
122+ tellEvent = lift . tellEvent
123+
124+instance MonadTrans (EventWriterT t w) where
125+ lift = EventWriterT . lift
126+
127+instance MonadSample t m => MonadSample t (EventWriterT t w m) where
128+ sample = lift . sample
129+
130+instance MonadHold t m => MonadHold t (EventWriterT t w m) where
131+ hold v0 = lift . hold v0
132+ holdDyn v0 = lift . holdDyn v0
133+ holdIncremental v0 = lift . holdIncremental v0
134+
135+instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w, Semigroup w) => MonadAdjust 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 'MonadAdjust' instance or to override the default
150+-- 'MonadAdjust' 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+ request <- holdDyn (snd result0) $ fmapCheap snd result'
159+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
160+ tellEvent $ coincidence $ updated request
161+ tellEvent $ switch $ current request
162+ return (fst result0, fmapCheap fst result')
163+
164+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
165+sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
166+ => ( (IntMap.Key -> v -> m (Event t w, v'))
167+ -> IntMap v
168+ -> Event t (p v)
169+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
170+ )
171+ -> (p (Event t w) -> [Event t w])
172+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
173+ -> (IntMap.Key -> v -> EventWriterT t w m v')
174+ -> IntMap v
175+ -> Event t (p v)
176+ -> EventWriterT t w m (IntMap v', Event t (p v'))
177+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
178+ let f' :: IntMap.Key -> v -> m (Event t w, v')
179+ f' k v = swap <$> runEventWriterT (f k v)
180+ (children0, children') <- base f' dm0 dm'
181+ let result0 = fmap snd children0
182+ result' = fmapCheap (fmap snd) children'
183+ requests0 :: IntMap (Event t w)
184+ requests0 = fmap fst children0
185+ requests' :: Event t (p (Event t w))
186+ requests' = fmapCheap (fmap fst) children'
187+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
188+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
189+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
190+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
191+ [] -> Nothing
192+ h : t -> Just $ sconcat $ h :| t
193+ return (result0, result')
194+
195+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
196+sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
197+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
198+ -> DMap k v
199+ -> Event t (p k v)
200+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
201+ )
202+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
203+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
204+ -> (p' (Some k) (Event t w) -> [Event t w])
205+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
206+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
207+ -> DMap k v
208+ -> Event t (p k v)
209+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
210+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
211+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
212+ f' k v = Compose . swap <$> runEventWriterT (f k v)
213+ (children0, children') <- base f' dm0 dm'
214+ let result0 = DMap.map (snd . getCompose) children0
215+ result' = fforCheap children' $ mapPatch $ snd . getCompose
216+ requests0 :: Map (Some k) (Event t w)
217+ requests0 = weakenDMapWith (fst . getCompose) children0
218+ requests' :: Event t (p' (Some k) (Event t w))
219+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
220+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
221+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
222+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
223+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
224+ [] -> Nothing
225+ h : t -> Just $ sconcat $ h :| t
226+ return (result0, result')
227+
228+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
229+ type Performable (EventWriterT t w m) = Performable m
230+ performEvent_ = lift . performEvent_
231+ performEvent = lift . performEvent
232+
233+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
234+ getPostBuild = lift getPostBuild
235+
236+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
237+ newTriggerEvent = lift newTriggerEvent
238+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
239+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
240+
241+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
242+ ask = lift ask
243+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
244+ reader = lift . reader
245+
246+instance MonadRef m => MonadRef (EventWriterT t w m) where
247+ type Ref (EventWriterT t w m) = Ref m
248+ newRef = lift . newRef
249+ readRef = lift . readRef
250+ writeRef r = lift . writeRef r
251+
252+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
253+ atomicModifyRef r = lift . atomicModifyRef r
254+
255+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
256+ newEventWithTrigger = lift . newEventWithTrigger
257+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
258+
259+instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
260+ tellQueryIncremental = lift . tellQueryIncremental
261+ askQueryResult = lift askQueryResult
262+ queryIncremental = lift . queryIncremental
src/Reflex/FastWeak.hsnew file+143
@@ -0,0 +1,143 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+#ifdef ghcjs_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
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_HOST_OS
135+ w = js_emptyWeak
136+foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any
137+#else
138+ w = unsafePerformIO $ do
139+ w' <- mkWeakPtr undefined Nothing
140+ finalize w'
141+ return w'
142+#endif
143+{-# NOINLINE emptyFastWeak #-}
src/Reflex/FunctorMaybe.hsnew file+29
@@ -0,0 +1,29 @@
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 f = catMaybes . fmap f@
28+instance FunctorMaybe [] where
29+ fmapMaybe f = catMaybes . fmap f
src/Reflex/Host/Class.hsnew file+299
@@ -0,0 +1,299 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RoleAnnotations #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+#ifdef USE_REFLEX_OPTIMIZER
14+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15+#endif
16+-- | This module provides the interface for hosting 'Reflex' engines. This
17+-- should only be necessary if you're writing a binding or some other library
18+-- that provides a core event loop.
19+module Reflex.Host.Class
20+ ( ReflexHost (..)
21+ , MonadSubscribeEvent (..)
22+ , MonadReadEvent (..)
23+ , MonadReflexCreateTrigger (..)
24+ , MonadReflexHost (..)
25+ , fireEvents
26+ , newEventWithTriggerRef
27+ , fireEventRef
28+ , fireEventRefAndRead
29+ ) where
30+
31+import Reflex.Class
32+
33+import Control.Applicative
34+import Control.Monad
35+import Control.Monad.Fix
36+import Control.Monad.Identity
37+import Control.Monad.Ref
38+import Control.Monad.Trans
39+import Control.Monad.Trans.Cont (ContT ())
40+import Control.Monad.Trans.Except (ExceptT ())
41+import Control.Monad.Trans.Reader (ReaderT ())
42+import Control.Monad.Trans.RWS (RWST ())
43+import Control.Monad.Trans.State (StateT ())
44+import qualified Control.Monad.Trans.State.Strict as Strict
45+import Control.Monad.Trans.Writer (WriterT ())
46+import Data.Dependent.Sum (DSum (..))
47+import Data.GADT.Compare
48+import Data.Monoid
49+
50+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
51+import Control.Monad.Primitive (touch)
52+import Data.IORef
53+import Reflex.Spider.Internal (EventM (..), HasSpiderTimeline, RootTrigger, SpiderEventHandle (..),
54+ SpiderHost (..), SpiderHostFrame (..), Subscriber (..), newEventWithTriggerIO,
55+ newFanEventWithTriggerIO, run, runFrame, scheduleClear, subscribe)
56+import qualified Reflex.Spider.Internal
57+#endif
58+
59+-- Note: this import must come last to silence warnings from AMP
60+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
61+
62+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
63+#include "../Spider/SpiderTimelineHost.include.hs"
64+#endif
65+
66+-- | Framework implementation support class for the reflex implementation
67+-- represented by @t@.
68+class ( Reflex t
69+ , MonadReflexCreateTrigger t (HostFrame t)
70+ , MonadSample t (HostFrame t)
71+ , MonadHold t (HostFrame t)
72+ , MonadFix (HostFrame t)
73+ , MonadSubscribeEvent t (HostFrame t)
74+ ) => ReflexHost t where
75+ type EventTrigger t :: * -> *
76+ type EventHandle t :: * -> *
77+ type HostFrame t :: * -> *
78+
79+-- | Monad in which Events can be 'subscribed'. This forces all underlying
80+-- event sources to be initialized, so that the event will fire whenever it
81+-- ought to. Events must be subscribed before they are read using readEvent
82+class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where
83+ -- | Subscribe to an event and set it up if needed.
84+ --
85+ -- This function will create a new 'EventHandle' from an 'Event'. This handle
86+ -- may then be used via 'readEvent' in the read callback of
87+ -- 'fireEventsAndRead'.
88+ --
89+ -- If the event wasn't subscribed to before (either manually or through a
90+ -- dependent event or behavior) then this function will cause the event and
91+ -- all dependencies of this event to be set up. For example, if the event was
92+ -- created by 'newEventWithTrigger', then it's callback will be executed.
93+ --
94+ -- It's safe to call this function multiple times.
95+ subscribeEvent :: Event t a -> m (EventHandle t a)
96+
97+-- | Monad that allows to read events' values.
98+class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where
99+ -- | Read the value of an 'Event' from an 'EventHandle' (created by calling
100+ -- 'subscribeEvent').
101+ --
102+ -- After event propagation is done, all events can be in two states: either
103+ -- they are firing with some value or they are not firing. In the former
104+ -- case, this function returns @Just act@, where @act@ in an action to read
105+ -- the current value of the event. In the latter case, the function returns
106+ -- @Nothing@.
107+ --
108+ -- This function is normally used in the calllback for 'fireEventsAndRead'.
109+ readEvent :: EventHandle t a -> m (Maybe (m a))
110+
111+-- | A monad where new events feed from external sources can be created.
112+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where
113+ -- | Creates a root 'Event' (one that is not based on any other event).
114+ --
115+ -- When a subscriber first subscribes to an event (building another event that
116+ -- depends on the subscription) the given callback function is run and passed
117+ -- a trigger. The callback function can then set up the event source in IO.
118+ -- After this is done, the callback function must return an accompanying
119+ -- teardown action.
120+ --
121+ -- Any time between setup and teardown the trigger can be used to fire the
122+ -- event, by passing it to 'fireEventsAndRead'.
123+ --
124+ -- Note: An event may be set up multiple times. So after the teardown action
125+ -- is executed, the event may still be set up again in the future.
126+ newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
127+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)
128+
129+-- | 'MonadReflexHost' designates monads that can run reflex frames.
130+class ( ReflexHost t
131+ , MonadReflexCreateTrigger t m
132+ , MonadSubscribeEvent t m
133+ , MonadReadEvent t (ReadPhase m)
134+ , MonadSample t (ReadPhase m)
135+ , MonadHold t (ReadPhase m)
136+ ) => MonadReflexHost t m | m -> t where
137+ type ReadPhase m :: * -> *
138+ -- | Propagate some events firings and read the values of events afterwards.
139+ --
140+ -- This function will create a new frame to fire the given events. It will
141+ -- then update all dependent events and behaviors. After that is done, the
142+ -- given callback is executed which allows to read the final values of events
143+ -- and check whether they have fired in this frame or not.
144+ --
145+ -- All events that are given are fired at the same time.
146+ --
147+ -- This function is typically used in the main loop of a reflex framework
148+ -- implementation. The main loop waits for external events to happen (such as
149+ -- keyboard input or a mouse click) and then fires the corresponding events
150+ -- using this function. The read callback can be used to read output events
151+ -- and perform a corresponding response action to the external event.
152+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a
153+
154+ -- | Run a frame without any events firing.
155+ --
156+ -- This function should be used when you want to use 'sample' and 'hold' when
157+ -- no events are currently firing. Using this function in that case can
158+ -- improve performance, since the implementation can assume that no events are
159+ -- firing when 'sample' or 'hold' are called.
160+ --
161+ -- This function is commonly used to set up the basic event network when the
162+ -- application starts up.
163+ runHostFrame :: HostFrame t a -> m a
164+
165+-- | Like 'fireEventsAndRead', but without reading any events.
166+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()
167+fireEvents dm = fireEventsAndRead dm $ return ()
168+{-# INLINE fireEvents #-}
169+
170+-- | Create a new event and store its trigger in an 'IORef' while it's active.
171+--
172+-- An event is only active between the set up (when it's first subscribed to)
173+-- and the teardown phases (when noboby is subscribing the event anymore). This
174+-- function returns an Event and an 'IORef'. As long as the event is active, the
175+-- 'IORef' will contain 'Just' the event trigger to trigger this event. When the
176+-- event is not active, the 'IORef' will contain 'Nothing'. This allows event
177+-- sources to be more efficient, since they don't need to produce events when
178+-- nobody is listening.
179+newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))
180+newEventWithTriggerRef = do
181+ rt <- newRef Nothing
182+ e <- newEventWithTrigger $ \t -> do
183+ writeRef rt $ Just t
184+ return $ writeRef rt Nothing
185+ return (e, rt)
186+{-# INLINE newEventWithTriggerRef #-}
187+
188+-- | Fire the given trigger if it is not 'Nothing'.
189+fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
190+fireEventRef mtRef input = do
191+ mt <- readRef mtRef
192+ case mt of
193+ Nothing -> return ()
194+ Just trigger -> fireEvents [trigger :=> Identity input]
195+
196+-- | Fire the given trigger if it is not 'Nothing', and read from the given
197+-- 'EventHandle'.
198+fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)
199+fireEventRefAndRead mtRef input e = do
200+ mt <- readRef mtRef
201+ case mt of
202+ Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire
203+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do
204+ mGetValue <- readEvent e
205+ case mGetValue of
206+ Nothing -> return Nothing
207+ Just getValue -> fmap Just getValue
208+
209+
210+--------------------------------------------------------------------------------
211+-- Instances
212+--------------------------------------------------------------------------------
213+
214+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where
215+ newEventWithTrigger = lift . newEventWithTrigger
216+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
217+
218+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where
219+ subscribeEvent = lift . subscribeEvent
220+
221+instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where
222+ type ReadPhase (ReaderT r m) = ReadPhase m
223+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
224+ runHostFrame = lift . runHostFrame
225+
226+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where
227+ newEventWithTrigger = lift . newEventWithTrigger
228+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
229+
230+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where
231+ subscribeEvent = lift . subscribeEvent
232+
233+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where
234+ type ReadPhase (WriterT w m) = ReadPhase m
235+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
236+ runHostFrame = lift . runHostFrame
237+
238+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where
239+ newEventWithTrigger = lift . newEventWithTrigger
240+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
241+
242+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where
243+ subscribeEvent = lift . subscribeEvent
244+
245+instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where
246+ type ReadPhase (StateT s m) = ReadPhase m
247+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
248+ runHostFrame = lift . runHostFrame
249+
250+
251+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where
252+ newEventWithTrigger = lift . newEventWithTrigger
253+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
254+
255+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (Strict.StateT r m) where
256+ subscribeEvent = lift . subscribeEvent
257+
258+instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where
259+ type ReadPhase (Strict.StateT s m) = ReadPhase m
260+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
261+ runHostFrame = lift . runHostFrame
262+
263+
264+
265+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where
266+ newEventWithTrigger = lift . newEventWithTrigger
267+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
268+
269+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where
270+ subscribeEvent = lift . subscribeEvent
271+
272+instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where
273+ type ReadPhase (ContT r m) = ReadPhase m
274+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
275+ runHostFrame = lift . runHostFrame
276+
277+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where
278+ newEventWithTrigger = lift . newEventWithTrigger
279+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
280+
281+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where
282+ subscribeEvent = lift . subscribeEvent
283+
284+instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where
285+ type ReadPhase (ExceptT e m) = ReadPhase m
286+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
287+ runHostFrame = lift . runHostFrame
288+
289+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where
290+ newEventWithTrigger = lift . newEventWithTrigger
291+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
292+
293+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where
294+ subscribeEvent = lift . subscribeEvent
295+
296+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where
297+ type ReadPhase (RWST r w s m) = ReadPhase m
298+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
299+ runHostFrame = lift . runHostFrame
src/Reflex/Optimizer.hsnew file+51
@@ -0,0 +1,51 @@
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 = return $ makeInlinable : p
35+install options@(_:_) p = do
36+ warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"
37+ install [] p
38+
39+makeInlinable :: CoreToDo
40+makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do
41+ let f v = setIdInfo v $ let i = idInfo v in
42+ setInlinePragInfo i $ let p = inlinePragInfo i in
43+ if isDefaultInlinePragma p
44+ then defaultInlinePragma { inl_inline = Inlinable }
45+ else p
46+ newBinds = flip map (mg_binds modGuts) $ \case
47+ NonRec b e -> NonRec (f b) e
48+ Rec bes -> Rec $ map (first f) bes
49+ return $ modGuts { mg_binds = newBinds }
50+
51+#endif
src/Reflex/Patch.hsnew file+33
@@ -0,0 +1,33 @@
1+-- | This module defines the 'Patch' class, which is used by Reflex to manage
2+-- changes to 'Reflex.Class.Incremental' values.
3+{-# LANGUAGE TypeFamilies #-}
4+module Reflex.Patch
5+ ( module Reflex.Patch
6+ , module X
7+ ) where
8+
9+import Reflex.Patch.Class as X
10+import Reflex.Patch.DMap as X
11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)
12+import Reflex.Patch.Map as X
13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElementsMap, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)
14+
15+import Data.Semigroup (Semigroup (..), (<>))
16+
17+---- Patches based on commutative groups
18+
19+-- | A 'Group' is a 'Monoid' where every element has an inverse.
20+class (Semigroup q, Monoid q) => Group q where
21+ negateG :: q -> q
22+ (~~) :: q -> q -> q
23+ r ~~ s = r <> negateG s
24+
25+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
26+class Semigroup q => Additive q where
27+
28+-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
29+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
30+
31+instance Additive p => Patch (AdditivePatch p) where
32+ type PatchTarget (AdditivePatch p) = p
33+ apply (AdditivePatch p) q = Just $ p <> q
src/Reflex/Patch/Class.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# LANGUAGE TypeFamilies #-}
2+module Reflex.Patch.Class where
3+
4+import Control.Monad.Identity
5+import Data.Maybe
6+
7+-- | A 'Patch' type represents a kind of change made to a datastructure.
8+class Patch p where
9+ type PatchTarget p :: *
10+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
11+ -- 'Nothing'.
12+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
13+
14+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
15+applyAlways p t = fromMaybe t $ apply p t
16+
17+instance Patch (Identity a) where
18+ type PatchTarget (Identity a) = a
19+ apply (Identity a) _ = Just a
20+
src/Reflex/Patch/DMap.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TypeFamilies #-}
8+module Reflex.Patch.DMap where
9+
10+import Reflex.Patch.Class
11+import Reflex.Patch.Map
12+
13+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
14+import qualified Data.Dependent.Map as DMap
15+import Data.Functor.Constant
16+import Data.Functor.Misc
17+import qualified Data.Map as Map
18+import Data.Semigroup (Semigroup (..))
19+import Data.Some (Some)
20+
21+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
22+-- deleted.
23+newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
24+
25+deriving instance GCompare k => Semigroup (PatchDMap k v)
26+
27+deriving instance GCompare k => Monoid (PatchDMap k v)
28+
29+instance GCompare k => Patch (PatchDMap k v) where
30+ type PatchTarget (PatchDMap k v) = DMap k v
31+ apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
32+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
33+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
34+ nothingToJust = \case
35+ Nothing -> Just $ Constant ()
36+ Just _ -> Nothing
37+
38+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
39+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
40+
41+traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
42+traversePatchDMap f = traversePatchDMapWithKey $ const f
43+
44+traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
45+traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
46+
47+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
48+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
49+
50+patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
51+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
52+
53+const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
54+const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
55+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
56+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
57+
58+-- | Get the values that will be deleted if the given patch is applied to the
59+-- given 'DMap'. Includes values that will be replaced.
60+getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
61+getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
src/Data/Patch/DMapWithMove.hs → src/Reflex/Patch/DMapWithMove.hsrenamed+68−158
@@ -10,122 +10,85 @@
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
13+module Reflex.Patch.DMapWithMove where
13
14
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+import Reflex.Patch.Class
15−-- move values between keys.
16+import Reflex.Patch.MapWithMove (PatchMapWithMove (..))
16−module Data.Patch.DMapWithMove where
17+import qualified Reflex.Patch.MapWithMove as MapWithMove
17
18
18−import Data.Patch.Class
19−import Data.Patch.MapWithMove (PatchMapWithMove (..))
20−import qualified Data.Patch.MapWithMove as MapWithMove
21−
22−import Data.Constraint.Extras
23−import Data.Dependent.Map (DMap)
19+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24−import Data.Dependent.Sum (DSum (..))
25import qualified Data.Dependent.Map as DMap
20import qualified Data.Dependent.Map as DMap
21+import Data.Dependent.Sum (EqTag (..))
26import Data.Functor.Constant
22import Data.Functor.Constant
27import Data.Functor.Misc
23import Data.Functor.Misc
28import Data.Functor.Product
24import Data.Functor.Product
29−import Data.GADT.Compare (GEq (..), GCompare (..))
25+import Data.GADT.Compare (GEq (..))
30−import Data.GADT.Show (GShow, gshow)
31import qualified Data.Map as Map
26import qualified Data.Map as Map
32import Data.Maybe
27import Data.Maybe
33−import Data.Monoid.DecidablyEmpty
28+import Data.Semigroup (Semigroup (..), (<>))
34−#if !MIN_VERSION_base(4,11,0)
35−import Data.Semigroup (Semigroup (..))
29+import Data.Some (Some)
36−#endif
37−import Data.Some (Some, mkSome)
30+import qualified Data.Some as Some
38import Data.These
31import Data.These
39
32
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
33+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
41−-- destinations.
34+import Data.Dependent.Sum (ShowTag (..))
42−--
35+import Data.GADT.Show (GShow (..))
43−-- Invariants:
36+import Data.Typeable (Proxy (..))
44−--
37+#endif
45−-- * A key should not move to itself.
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)@)
47−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
48
38
49−-- It won't let me derive for some reason
39+-- | Like 'PatchMapWithMove', but for 'DMap'.
50−instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
40+newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
51− isEmpty (PatchDMapWithMove m) = DMap.null m
41+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
42+ deriving (Show)
43+#endif
52
44
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
54−-- 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
45data NodeInfo k v a = NodeInfo
56 { _nodeInfo_from :: !(From k v a)
46 { _nodeInfo_from :: !(From k v a)
57− -- ^Change applying to the current key, be it an insert, move, or delete.
58 , _nodeInfo_to :: !(To k a)
47 , _nodeInfo_to :: !(To k a)
59− -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
60 }
48 }
61 deriving (Show)
49 deriving (Show)
62
50
63−-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
51+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
64−-- key (@From_Delete@), or moving a key (@From_Move@).
52+instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (NodeInfo k v) where
53+ showTagToShow k _ r = gshowToShow k $ showTagToShow k (Proxy :: Proxy v) r
54+
55+instance {-# INCOHERENT #-} (GEq k, EqTag k v) => EqTag k (From k v) where
56+ eqTagToEq k _ r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)
57+#endif
58+
65data From (k :: a -> *) (v :: a -> *) :: a -> * where
59data From (k :: a -> *) (v :: a -> *) :: a -> * where
66− -- |Insert a new or update an existing key with the given value @v a@
67 From_Insert :: v a -> From k v a
60 From_Insert :: v a -> From k v a
68− -- |Delete the existing key
69 From_Delete :: From k v a
61 From_Delete :: From k v a
70− -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
71− -- usually but not necessarily with @From_Delete@.
72 From_Move :: !(k a) -> From k v a
62 From_Move :: !(k a) -> From k v a
73 deriving (Show, Read, Eq, Ord)
63 deriving (Show, Read, Eq, Ord)
74
64
75−-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
76−-- operation.
77type To = ComposeMaybe
65type To = ComposeMaybe
78
66
79−-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
80−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
67+validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
81−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
68+validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst
82−
83−-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
84−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
85−validationErrorsForPatchDMapWithMove m =
86− noSelfMoves <> movesBalanced
87 where
69 where
88− noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
70+ src = DMap.map _nodeInfo_to m
89− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
71+ dst = DMap.map _nodeInfo_from m
90− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
72+ srcFromDst :: DMap k (ComposeMaybe k)
91− selfMove _ = Nothing
73+ srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of
92− movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
74+ From_Move from -> from :=> ComposeMaybe (Just to)
93− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
94− case DMap.lookup src m of
95− Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
96− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
97− if isNothing (dst' `geq` dst)
98− then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
99− else Nothing
75+ _ -> to :=> ComposeMaybe Nothing
100− _ ->
76+
101− Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
102− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
103− case DMap.lookup dst m of
104− Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
105− Just (NodeInfo (From_Move src') _) ->
106− if isNothing (src' `geq` src)
107− then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
108− else Nothing
109−
110− _ ->
111− Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
112− unbalancedMove _ = Nothing
113−
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
77+instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
116− PatchDMapWithMove a == PatchDMapWithMove b = a == b
78+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
117−
79+
118−-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
119data Pair1 f g a = Pair1 (f a) (g a)
80data Pair1 f g a = Pair1 (f a) (g a)
120
81
121−-- |Helper data structure used for composing patches using the monoid instance.
82+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
83+ (<>) = mappend
84+
122data Fixup k v a
85data Fixup k v a
123 = Fixup_Delete
86 = Fixup_Delete
124 | Fixup_Update (These (From k v a) (To k a))
87 | Fixup_Update (These (From k v a) (To k a))
125
88
126−-- |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
89+instance GCompare k => Monoid (PatchDMapWithMove k v) where
90+ mempty = PatchDMapWithMove mempty
128− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
91+ PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m
129 where
92 where
130 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
93 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)]
94 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
@@ -159,21 +122,18 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
159 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
122 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
160 }
123 }
161 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
124 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
125+
162− getHere :: These a b -> Maybe a
126+getHere :: These a b -> Maybe a
163− getHere = \case
127+getHere = \case
164− This a -> Just a
128+ This a -> Just a
165− These a _ -> Just a
129+ These a _ -> Just a
166− That _ -> Nothing
130+ That _ -> Nothing
131+
167− getThere :: These a b -> Maybe b
132+getThere :: These a b -> Maybe b
168− getThere = \case
133+getThere = \case
169− This _ -> Nothing
134+ This _ -> Nothing
170− These _ b -> Just b
135+ These _ b -> Just b
171− That b -> Just b
136+ That b -> Just b
172−
173−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
174−instance GCompare k => Monoid (PatchDMapWithMove k v) where
175− mempty = PatchDMapWithMove mempty
176− mappend = (<>)
177
137
178{-
138{-
179mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
139mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
@@ -197,16 +157,6 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
157 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
198-}
158-}
199
159
200−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
201−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
202−insertDMapKey k v =
203− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
204−
205−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
206−--
207−-- @
208−-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
209−-- @
210moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
160moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
211moveDMapKey src dst = case src `geq` dst of
161moveDMapKey src dst = case src `geq` dst of
212 Nothing -> PatchDMapWithMove $ DMap.fromList
162 Nothing -> PatchDMapWithMove $ DMap.fromList
@@ -215,24 +165,6 @@ moveDMapKey src dst = case src `geq` dst of
215 ]
165 ]
216 Just _ -> mempty
166 Just _ -> mempty
217
167
218−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
219−--
220−-- @
221−-- let aMay = DMap.lookup a dmap
222−-- bMay = DMap.lookup b dmap
223−-- in maybe id (DMap.insert a) (bMay <> aMay)
224−-- . maybe id (DMap.insert b) (aMay <> bMay)
225−-- . DMap.delete a . DMap.delete b $ dmap
226−-- @
227−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
228−swapDMapKey src dst = case src `geq` dst of
229− Nothing -> PatchDMapWithMove $ DMap.fromList
230− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
231− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
232− ]
233− Just _ -> mempty
234−
235−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
236deleteDMapKey :: k a -> PatchDMapWithMove k v
168deleteDMapKey :: k a -> PatchDMapWithMove k v
237deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
169deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
238
170
@@ -260,25 +192,14 @@ dst (PatchDMapWithMove x _) = x
260src (PatchDMapWithMove _ x) = x
192src (PatchDMapWithMove _ x) = x
261-}
193-}
262
194
263−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
264unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
195unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
265unPatchDMapWithMove (PatchDMapWithMove p) = p
196unPatchDMapWithMove (PatchDMapWithMove p) = p
266
197
267−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
268−--
269−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
198+-- | Warning: when using this function, you must ensure that the invariants of
199+-- 'PatchDMapWithMove' are preserved; they will not be checked.
270unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
200unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
271unsafePatchDMapWithMove = PatchDMapWithMove
201unsafePatchDMapWithMove = PatchDMapWithMove
272
202
273−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
274−-- otherwise @Left errors@.
275−patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
276−patchDMapWithMove dm =
277− case validationErrorsForPatchDMapWithMove dm of
278− [] -> Right $ unsafePatchDMapWithMove dm
279− errs -> Left errs
280−
281−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
282mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
203mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
283mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
204mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
284 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
205 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
@@ -288,11 +209,9 @@ mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
288 From_Delete -> From_Delete
209 From_Delete -> From_Delete
289 From_Move k -> From_Move k
210 From_Move k -> From_Move k
290
211
291−-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
292traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
212traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
293traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
213traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
294
214
295−-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
296traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
215traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
297traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
216traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
298 where g :: forall a. k a -> From k v a -> m (From k v' a)
217 where g :: forall a. k a -> From k v a -> m (From k v' a)
@@ -301,16 +220,12 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$>
301 From_Delete -> pure From_Delete
220 From_Delete -> pure From_Delete
302 From_Move fromKey -> pure $ From_Move fromKey
221 From_Move fromKey -> pure $ From_Move fromKey
303
222
304−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
305nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
223nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
306nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
224nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
307
225
308−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
309nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
226nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
310nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
227nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
311
228
312−-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
313−-- values.
314weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
229weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
315weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
230weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
316 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
231 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
@@ -318,15 +233,13 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
233 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
319 From_Insert v -> MapWithMove.From_Insert $ f v
234 From_Insert v -> MapWithMove.From_Insert $ f v
320 From_Delete -> MapWithMove.From_Delete
235 From_Delete -> MapWithMove.From_Delete
321− From_Move k -> MapWithMove.From_Move $ mkSome k
236+ From_Move k -> MapWithMove.From_Move $ Some.This k
322− , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
237+ , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
323 }
238 }
324
239
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
326−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
327−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
240+patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
328patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
241patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
329− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
242+ where g :: NodeInfo (Const2 k v) f v -> MapWithMove.NodeInfo k v'
330 g ni = MapWithMove.NodeInfo
243 g ni = MapWithMove.NodeInfo
331 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
244 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
332 From_Insert v -> MapWithMove.From_Insert $ f v
245 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -335,12 +248,9 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
335 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
248 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
336 }
249 }
337
250
338−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
339−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
340−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
341−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
251+const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
342const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
252const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
343− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
253+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) f)
344 g (k, ni) = Const2 k :=> NodeInfo
254 g (k, ni) = Const2 k :=> NodeInfo
345 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
255 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
346 MapWithMove.From_Insert v -> From_Insert $ f v
256 MapWithMove.From_Insert v -> From_Insert $ f v
@@ -349,7 +259,6 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
349 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
259 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
350 }
260 }
351
261
352−-- | Apply the insertions, deletions, and moves to a given 'DMap'.
353instance GCompare k => Patch (PatchDMapWithMove k v) where
262instance GCompare k => Patch (PatchDMapWithMove k v) where
354 type PatchTarget (PatchDMapWithMove k v) = DMap k v
263 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?
264 apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
@@ -365,7 +274,8 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where
365 From_Delete -> Just $ Constant ()
274 From_Delete -> Just $ Constant ()
366 _ -> Nothing
275 _ -> Nothing
367
276
368−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
277+-- | Get the values that will be deleted or moved if the given patch is applied
278+-- to the given 'DMap'.
369getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
279getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
280getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
371 where f _ v ni = Pair v $ _nodeInfo_to ni
281 where f _ v ni = Pair v $ _nodeInfo_to ni
src/Data/Patch/Map.hs → src/Reflex/Patch/Map.hsrenamed+22−42
@@ -1,50 +1,19 @@
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 #-}
4+module Reflex.Patch.Map where
10
5
11−-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
6+import Reflex.Patch.Class
12−-- and deletions
13−module Data.Patch.Map where
14
7
15−import Data.Patch.Class
8+import Data.Semigroup
16−
17−import Control.Lens
18import Data.Map (Map)
9import Data.Map (Map)
19import qualified Data.Map as Map
10import qualified Data.Map as Map
20import Data.Maybe
11import Data.Maybe
21−import Data.Monoid.DecidablyEmpty
22−import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
23
12
24-- | A set of changes to a 'Map'. Any element may be inserted/updated or
13-- | 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
14+-- deleted.
26−-- deletions are represented as 'Nothing's
27newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
15newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
28− 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
16
47−-- | Apply the insertions or deletions to a given 'Map'.
48instance Ord k => Patch (PatchMap k v) where
17instance Ord k => Patch (PatchMap k v) where
49 type PatchTarget (PatchMap k v) = Map k v
18 type PatchTarget (PatchMap k v) = Map k v
50 {-# INLINABLE apply #-}
19 {-# INLINABLE apply #-}
@@ -55,11 +24,24 @@ instance Ord k => Patch (PatchMap k v) where
55 Nothing -> Just ()
24 Nothing -> Just ()
56 Just _ -> Nothing
25 Just _ -> Nothing
57
26
58−instance FunctorWithIndex k (PatchMap k)
27+instance Ord k => Semigroup (PatchMap k v) where
59−instance FoldableWithIndex k (PatchMap k)
28+ PatchMap a <> PatchMap b = PatchMap $ 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+
60−instance TraversableWithIndex k (PatchMap k) where
39+instance Ord k => Monoid (PatchMap k v) where
61− itraverse = itraversed . Indexed
40+ mempty = PatchMap mempty
62− itraversed = _Wrapped .> itraversed <. traversed
41+ mappend = (<>)
42+
43+instance Functor (PatchMap k) where
44+ fmap f = PatchMap . fmap (fmap f) . unPatchMap
63
45
64-- | Returns all the new elements that will be added to the 'Map'
46-- | Returns all the new elements that will be added to the 'Map'
65patchMapNewElements :: PatchMap k v -> [v]
47patchMapNewElements :: PatchMap k v -> [v]
@@ -68,5 +50,3 @@ patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
68-- | Returns all the new elements that will be added to the 'Map'
50-- | Returns all the new elements that will be added to the 'Map'
69patchMapNewElementsMap :: PatchMap k v -> Map k v
51patchMapNewElementsMap :: PatchMap k v -> Map k v
70patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
52patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
71−
72−makeWrapped ''PatchMap
src/Reflex/Patch/MapWithMove.hsnew file+159
@@ -0,0 +1,159 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+module Reflex.Patch.MapWithMove where
9+
10+import Reflex.Patch.Class
11+
12+import Control.Arrow
13+import Control.Monad.State
14+import Data.Foldable
15+import Data.Function
16+import Data.List
17+import Data.Map (Map)
18+import qualified Data.Map as Map
19+import Data.Maybe
20+import qualified Data.Set as Set
21+import Data.Tuple
22+
23+-- | Patch a DMap with additions, deletions, and moves.
24+-- Invariants:
25+-- * The same source key may not be moved to two destination keys.
26+-- * Any key that is the source of a Move must also be edited
27+-- (otherwise, the Move would duplicate it)
28+newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
29+
30+data NodeInfo k v = NodeInfo
31+ { _nodeInfo_from :: !(From k v)
32+ , _nodeInfo_to :: !(To k)
33+ }
34+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
35+
36+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
37+unPatchMapWithMove (PatchMapWithMove p) = p
38+
39+-- | Warning: when using this function, you must ensure that the invariants of
40+-- 'PatchMapWithMove' are preserved; they will not be checked.
41+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
42+unsafePatchMapWithMove = PatchMapWithMove
43+
44+data From k v
45+ = From_Insert v -- ^ Insert the given value here
46+ | From_Delete -- ^ Delete the existing value, if any, from here
47+ | From_Move !k -- ^ Move the value here from the given key
48+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
49+
50+type To = Maybe
51+
52+instance Ord k => Patch (PatchMapWithMove k v) where
53+ type PatchTarget (PatchMapWithMove k v) = Map k v
54+ apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
55+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
56+ From_Insert v -> Just v
57+ From_Move k -> Map.lookup k old
58+ From_Delete -> Nothing
59+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
60+ From_Delete -> Just ()
61+ _ -> Nothing
62+
63+-- | Returns all the new elements that will be added to the 'Map'
64+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
65+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
66+
67+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
68+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
69+ where f ni = case _nodeInfo_from ni of
70+ From_Insert v -> Just v
71+ From_Move _ -> Nothing
72+ From_Delete -> Nothing
73+
74+validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
75+validPatchMapWithMove (PatchMapWithMove p) =
76+ let f ni = case _nodeInfo_from ni of
77+ From_Move k -> Just k
78+ _ -> Nothing
79+ moveSources = catMaybes $ f <$> Map.elems p
80+ in and
81+ [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
82+ all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
83+ , -- All Move source keys must also be patched - since the value's being moved elsewhere, the original must either be Deleted or replaced (with Insert or Move)
84+ all (isJust . flip Map.lookup p) moveSources
85+ ]
86+
87+knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
88+knownValidPatchMapWithMove =
89+ [ PatchMapWithMove mempty
90+ , PatchMapWithMove $ Map.fromList
91+ [ (1, NodeInfo (From_Move 2) $ Just 1)
92+ , (2, NodeInfo (From_Move 1) $ Just 2)
93+ ]
94+ ]
95+
96+knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
97+knownInvalidPatchMapWithMove =
98+ [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
99+ PatchMapWithMove $ Map.singleton 1 $ NodeInfo (From_Move 2) Nothing
100+ , -- Invalid because we have multiple moves from 3
101+ PatchMapWithMove $ Map.fromList
102+ [ (1, NodeInfo (From_Move 3) Nothing)
103+ , (2, NodeInfo (From_Move 3) Nothing)
104+ , (3, NodeInfo From_Delete (Just 1))
105+ ]
106+ ]
107+
108+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
109+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
110+ where unsorted = Map.toList m
111+ sorted = sortBy (cmp `on` snd) unsorted
112+ f (to, _) (from, _) = if to == from then Nothing else
113+ Just (from, to)
114+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
115+ g (to, _) (from, _) = if to == from then Nothing else
116+ let Just movingTo = Map.lookup from reverseMapping
117+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)
118+
119+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
120+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
121+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
122+ newList = Map.toList newByIndexUnsorted
123+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
124+ insertsAndMoves :: Map k (NodeInfo k v)
125+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
126+ let f k v = do
127+ remainingValues <- get
128+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
129+ then Map.delete v remainingValues
130+ else Map.insert v remainingKeys remainingValues
131+ case Map.lookup v remainingValues of
132+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
133+ Just fromKs ->
134+ if k `Set.member` fromKs
135+ then do
136+ putRemainingKeys $ Set.delete k fromKs
137+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
138+ else do
139+ Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
140+ putRemainingKeys remainingKeys
141+ return $ NodeInfo (From_Move fromK) $ Just undefined
142+ Map.traverseWithKey f newByIndex
143+ unusedOldKeys = fold unusedValuesByValue
144+ pointlessMove k = \case
145+ From_Move k' | k == k' -> True
146+ _ -> False
147+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
148+ then Just undefined
149+ else Nothing
150+ 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
151+
152+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
153+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
154+
155+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
156+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
157+
158+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
159+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
src/Reflex/PerformEvent/Base.hsnew file+174
@@ -0,0 +1,174 @@
1+-- | This module provides 'PerformEventT', the standard implementation of
2+-- 'PerformEvent'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PartialTypeSignatures #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#ifdef USE_REFLEX_OPTIMIZER
19+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
20+#endif
21+module Reflex.PerformEvent.Base
22+ ( PerformEventT (..)
23+ , FireCommand (..)
24+ , hostPerformEventT
25+ ) where
26+
27+import Reflex.Class
28+import Reflex.Host.Class
29+import Reflex.PerformEvent.Class
30+import Reflex.Requester.Base
31+import Reflex.Requester.Class
32+
33+import Control.Lens
34+import Control.Monad.Exception
35+import Control.Monad.Identity
36+import Control.Monad.Primitive
37+import Control.Monad.Reader
38+import Control.Monad.Ref
39+import Data.Coerce
40+import Data.Dependent.Map (DMap)
41+import qualified Data.Dependent.Map as DMap
42+import Data.Dependent.Sum
43+import Data.FastMutableIntMap
44+import Data.IntMap.Strict (IntMap)
45+import qualified Data.IntMap.Strict as IntMap
46+
47+-- | A function that fires events for the given 'EventTrigger's and then runs
48+-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
49+-- action will be run once for the initial trigger execution as well as once for
50+-- each followup.
51+newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?
52+
53+-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
54+-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
55+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
56+
57+deriving instance ReflexHost t => Functor (PerformEventT t m)
58+deriving instance ReflexHost t => Applicative (PerformEventT t m)
59+deriving instance ReflexHost t => Monad (PerformEventT t m)
60+deriving instance ReflexHost t => MonadFix (PerformEventT t m)
61+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
62+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
63+
64+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
65+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)
66+ primitive = PerformEventT . lift . primitive
67+
68+instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
69+ type Performable (PerformEventT t m) = HostFrame t
70+ {-# INLINABLE performEvent_ #-}
71+ performEvent_ = PerformEventT . requesting_
72+ {-# INLINABLE performEvent #-}
73+ performEvent = PerformEventT . requestingIdentity
74+
75+instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where
76+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
77+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
78+ f a0 a' = do
79+ result0 <- lift a0
80+ result' <- requestingIdentity a'
81+ return (result0, result')
82+ traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
83+ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
84+ traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
85+
86+defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
87+ => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
88+ -> (forall a. k' a -> v a -> HostFrame t (v2 a))
89+ -> DMap k' v
90+ -> Event t (p k' v)
91+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
92+defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
93+ result0 <- lift $ DMap.traverseWithKey f' dm0
94+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
95+ return (result0, result')
96+
97+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
98+ => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
99+ -> (IntMap.Key -> v -> HostFrame t v2)
100+ -> IntMap v
101+ -> Event t (p v)
102+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
103+defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
104+ result0 <- lift $ IntMap.traverseWithKey f' dm0
105+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
106+ return (result0, result')
107+
108+instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
109+ {-# INLINABLE newEventWithTrigger #-}
110+ newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
111+ {-# INLINABLE newFanEventWithTrigger #-}
112+ newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
113+
114+-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
115+-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
116+-- at the appropriate time.
117+{-# INLINABLE hostPerformEventT #-}
118+hostPerformEventT :: forall t m a.
119+ ( Monad m
120+ , MonadSubscribeEvent t m
121+ , MonadReflexHost t m
122+ , MonadRef m
123+ , Ref m ~ Ref IO
124+ )
125+ => PerformEventT t m a
126+ -> m (a, FireCommand t m)
127+hostPerformEventT a = do
128+ (response, responseTrigger) <- newEventWithTriggerRef
129+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
130+ eventToPerformHandle <- subscribeEvent eventToPerform
131+ return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
132+ let go :: [DSum (EventTrigger t) Identity] -> m [a']
133+ go ts = do
134+ (result', mToPerform) <- fireEventsAndRead ts $ do
135+ mToPerform <- sequence =<< readEvent eventToPerformHandle
136+ result' <- readPhase
137+ return (result', mToPerform)
138+ case mToPerform of
139+ Nothing -> return [result']
140+ Just toPerform -> do
141+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
142+ mrt <- readRef responseTrigger
143+ let followupEventTriggers = case mrt of
144+ Just rt -> [rt :=> Identity responses]
145+ Nothing -> []
146+ (result':) <$> go followupEventTriggers
147+ go triggers
148+
149+instance ReflexHost t => MonadSample t (PerformEventT t m) where
150+ {-# INLINABLE sample #-}
151+ sample = PerformEventT . lift . sample
152+
153+instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
154+ {-# INLINABLE hold #-}
155+ hold v0 v' = PerformEventT $ lift $ hold v0 v'
156+ {-# INLINABLE holdDyn #-}
157+ holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
158+ {-# INLINABLE holdIncremental #-}
159+ holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
160+ {-# INLINABLE buildDynamic #-}
161+ buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
162+
163+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
164+ type Ref (PerformEventT t m) = Ref (HostFrame t)
165+ {-# INLINABLE newRef #-}
166+ newRef = PerformEventT . lift . newRef
167+ {-# INLINABLE readRef #-}
168+ readRef = PerformEventT . lift . readRef
169+ {-# INLINABLE writeRef #-}
170+ writeRef r = PerformEventT . lift . writeRef r
171+
172+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
173+ {-# INLINABLE atomicModifyRef #-}
174+ 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+177
@@ -0,0 +1,177 @@
1+-- | This module defines 'PostBuildT', the standard implementation of
2+-- 'PostBuild'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RecursiveDo #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#ifdef USE_REFLEX_OPTIMIZER
15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16+#endif
17+module Reflex.PostBuild.Base
18+ ( PostBuildT (..)
19+ , runPostBuildT
20+ -- * Internal
21+ , mapIntMapWithAdjustImpl
22+ , mapDMapWithAdjustImpl
23+ ) where
24+
25+import Reflex.Class
26+import Reflex.Host.Class
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
29+import Reflex.TriggerEvent.Class
30+
31+import Control.Monad.Exception
32+import Control.Monad.Identity
33+import Control.Monad.Primitive
34+import Control.Monad.Reader
35+import Control.Monad.Ref
36+import Control.Monad.Trans.Control
37+import Data.Dependent.Map (DMap)
38+import qualified Data.Dependent.Map as DMap
39+import Data.Functor.Compose
40+import Data.IntMap.Strict (IntMap)
41+import qualified Data.IntMap.Strict as IntMap
42+
43+-- | Provides a basic implementation of 'PostBuild'.
44+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
45+
46+-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
47+-- immediately after the action is finished running; no other 'Event's should
48+-- fire first.
49+{-# INLINABLE runPostBuildT #-}
50+runPostBuildT :: PostBuildT t m a -> Event t () -> m a
51+runPostBuildT (PostBuildT a) = runReaderT a
52+
53+instance PrimMonad m => PrimMonad (PostBuildT x m) where
54+ type PrimState (PostBuildT x m) = PrimState m
55+ primitive = lift . primitive
56+
57+instance MonadTransControl (PostBuildT t) where
58+ type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
59+ {-# INLINABLE liftWith #-}
60+ liftWith = defaultLiftWith PostBuildT unPostBuildT
61+ {-# INLINABLE restoreT #-}
62+ restoreT = defaultRestoreT PostBuildT
63+
64+instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
65+ {-# INLINABLE getPostBuild #-}
66+ getPostBuild = PostBuildT ask
67+
68+instance MonadSample t m => MonadSample t (PostBuildT t m) where
69+ {-# INLINABLE sample #-}
70+ sample = lift . sample
71+
72+instance MonadHold t m => MonadHold t (PostBuildT t m) where
73+ {-# INLINABLE hold #-}
74+ hold v0 = lift . hold v0
75+ {-# INLINABLE holdDyn #-}
76+ holdDyn v0 = lift . holdDyn v0
77+ {-# INLINABLE holdIncremental #-}
78+ holdIncremental v0 = lift . holdIncremental v0
79+
80+instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
81+ type Performable (PostBuildT t m) = PostBuildT t (Performable m)
82+ {-# INLINABLE performEvent_ #-}
83+ performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
84+ {-# INLINABLE performEvent #-}
85+ performEvent e = liftWith $ \run -> performEvent $ fmap run e
86+
87+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
88+ {-# INLINABLE newEventWithTrigger #-}
89+ newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
90+ {-# INLINABLE newFanEventWithTrigger #-}
91+ newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
92+
93+instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
94+ {-# INLINABLE newTriggerEvent #-}
95+ newTriggerEvent = lift newTriggerEvent
96+ {-# INLINABLE newTriggerEventWithOnComplete #-}
97+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
98+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
99+
100+instance MonadRef m => MonadRef (PostBuildT t m) where
101+ type Ref (PostBuildT t m) = Ref m
102+ {-# INLINABLE newRef #-}
103+ newRef = lift . newRef
104+ {-# INLINABLE readRef #-}
105+ readRef = lift . readRef
106+ {-# INLINABLE writeRef #-}
107+ writeRef r = lift . writeRef r
108+
109+instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
110+ {-# INLINABLE atomicModifyRef #-}
111+ atomicModifyRef r = lift . atomicModifyRef r
112+
113+instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
114+ runWithReplace a0 a' = do
115+ postBuild <- getPostBuild
116+ lift $ do
117+ rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
118+ let voidResult' = fmapCheap (\_ -> ()) result'
119+ return result
120+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
121+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
122+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
123+ traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
124+ traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
125+
126+{-# INLINABLE mapIntMapWithAdjustImpl #-}
127+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
128+ => ( (IntMap.Key -> ((Bool, Event t ()), v) -> m v')
129+ -> IntMap ((Bool, Event t ()), v)
130+ -> Event t (p ((Bool, Event t ()), v))
131+ -> m (IntMap v', Event t (p v'))
132+ )
133+ -> (IntMap.Key -> v -> PostBuildT t m v')
134+ -> IntMap v
135+ -> Event t (p v)
136+ -> PostBuildT t m (IntMap v', Event t (p v'))
137+mapIntMapWithAdjustImpl base f dm0 dm' = do
138+ postBuild <- getPostBuild
139+ let loweredDm0 = fmap ((,) (False, postBuild)) dm0
140+ f' :: IntMap.Key -> ((Bool, Event t ()), v) -> m v'
141+ f' k ((shouldHeadE, e), v) = do
142+ eOnce <- if shouldHeadE
143+ 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
144+ else return e
145+ runPostBuildT (f k v) eOnce
146+ lift $ do
147+ rec (result0, result') <- base f' loweredDm0 loweredDm'
148+ let voidResult' = fmapCheap (\_ -> ()) result'
149+ let loweredDm' = ffor dm' $ fmap ((,) (True, voidResult'))
150+ return (result0, result')
151+
152+{-# INLINABLE mapDMapWithAdjustImpl #-}
153+mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
154+ => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
155+ -> DMap k (Compose ((,) (Bool, Event t ())) v)
156+ -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
157+ -> m (DMap k v', Event t (p k v'))
158+ )
159+ -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
160+ -> (forall a. k a -> v a -> PostBuildT t m (v' a))
161+ -> DMap k v
162+ -> Event t (p k v)
163+ -> PostBuildT t m (DMap k v', Event t (p k v'))
164+mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
165+ postBuild <- getPostBuild
166+ let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
167+ f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
168+ f' k (Compose ((shouldHeadE, e), v)) = do
169+ eOnce <- if shouldHeadE
170+ 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
171+ else return e
172+ runPostBuildT (f k v) eOnce
173+ lift $ do
174+ rec (result0, result') <- base f' loweredDm0 loweredDm'
175+ let voidResult' = fmapCheap (\_ -> ()) result'
176+ let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
177+ return (result0, result')
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/Pure.hsnew file+191
@@ -0,0 +1,191 @@
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.Maybe
38+import Data.MemoTrie
39+import Data.Monoid
40+import Data.Type.Coercion
41+import Reflex.Class
42+
43+-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
44+-- with the type @t@.
45+data Pure t
46+
47+-- | The Enum instance of t must be dense: for all x :: t, there must not exist
48+-- any y :: t such that pred x < y < x. The HasTrie instance will be used
49+-- exclusively to memoize functions of t, not for any of its other capabilities.
50+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
51+
52+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
53+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
54+ newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
55+ newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
56+
57+ type PushM (Pure t) = (->) t
58+ type PullM (Pure t) = (->) t
59+
60+ never :: Event (Pure t) a
61+ never = Event $ \_ -> Nothing
62+
63+ constant :: a -> Behavior (Pure t) a
64+ constant x = Behavior $ \_ -> x
65+
66+ push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
67+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
68+
69+ pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
70+ pushCheap = push
71+
72+ pull :: PullM (Pure t) a -> Behavior (Pure t) a
73+ pull = Behavior . memo
74+
75+ -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
76+ -- warning because the GCompare instance is not used; however, removing the
77+ -- GCompare instance produces a different warning, due to that constraint
78+ -- being present in the original class definition
79+
80+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
81+ merge events = Event $ memo $ \t ->
82+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
83+ in if DMap.null currentOccurrences
84+ then Nothing
85+ else Just currentOccurrences
86+
87+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
88+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
89+
90+ switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
91+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
92+
93+ coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
94+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
95+
96+ current :: Dynamic (Pure t) a -> Behavior (Pure t) a
97+ current d = Behavior $ \t -> fst $ unDynamic d t
98+
99+ updated :: Dynamic (Pure t) a -> Event (Pure t) a
100+ updated d = Event $ \t -> snd $ unDynamic d t
101+
102+ unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
103+ unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
104+
105+ -- See UNUSED_CONSTRAINT, above.
106+
107+ --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
108+ --a) -> Incremental (Pure t) p a
109+ unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
110+
111+ mergeIncremental = mergeIncrementalImpl
112+ mergeIncrementalWithMove = mergeIncrementalImpl
113+
114+ currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
115+
116+ updatedIncremental i = Event $ \t -> snd $ unIncremental i t
117+
118+ incrementalToDynamic i = Dynamic $ \t ->
119+ let (old, mPatch) = unIncremental i t
120+ e = case mPatch of
121+ Nothing -> Nothing
122+ Just patch -> apply patch old
123+ in (old, e)
124+ behaviorCoercion Coercion = Coercion
125+ eventCoercion Coercion = Coercion
126+ dynamicCoercion Coercion = Coercion
127+
128+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
129+mergeIncrementalImpl i = Event $ \t ->
130+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
131+ in if DMap.null results
132+ then Nothing
133+ else Just results
134+
135+instance Functor (Dynamic (Pure t)) where
136+ fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
137+ in (f cur, fmap f upd)
138+
139+instance Applicative (Dynamic (Pure t)) where
140+ pure a = Dynamic $ \_ -> (a, Nothing)
141+ (<*>) = ap
142+
143+instance Monad (Dynamic (Pure t)) where
144+ return = pure
145+ (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
146+ let (curX :: a, updX :: Maybe a) = unDynamic x t
147+ (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
148+ (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
149+ Nothing -> (Nothing, Nothing)
150+ Just nextX -> let (c, u) = unDynamic (f nextX) t
151+ in (Just c, u)
152+ in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
153+
154+instance MonadSample (Pure t) ((->) t) where
155+
156+ sample :: Behavior (Pure t) a -> (t -> a)
157+ sample = unBehavior
158+
159+instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
160+
161+ hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
162+ hold initialValue e initialTime = Behavior f
163+ where f = memo $ \sampleTime ->
164+ -- Really, the sampleTime should never be prior to the initialTime,
165+ -- because that would mean the Behavior is being sampled before
166+ -- being created.
167+ if sampleTime <= initialTime
168+ then initialValue
169+ else let lastTime = pred sampleTime
170+ in fromMaybe (f lastTime) $ unEvent e lastTime
171+
172+ holdDyn v0 = buildDynamic (return v0)
173+
174+ buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
175+ buildDynamic initialValue e initialTime =
176+ let Behavior f = hold (initialValue initialTime) e initialTime
177+ in Dynamic $ \t -> (f t, unEvent e t)
178+
179+ holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
180+ holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
181+ where f = memo $ \sampleTime ->
182+ -- Really, the sampleTime should never be prior to the initialTime,
183+ -- because that would mean the Behavior is being sampled before
184+ -- being created.
185+ if sampleTime <= initialTime
186+ then initialValue
187+ else let lastTime = pred sampleTime
188+ lastValue = f lastTime
189+ in case unEvent e lastTime of
190+ Nothing -> lastValue
191+ Just x -> fromMaybe lastValue $ apply x lastValue
src/Reflex/Query/Base.hsnew file+275
@@ -0,0 +1,275 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE InstanceSigs #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+module Reflex.Query.Base
11+ ( QueryT (..)
12+ , runQueryT
13+ , mapQuery
14+ , mapQueryResult
15+ , dynWithQueryT
16+ , withQueryT
17+ ) where
18+
19+import Control.Monad.Exception
20+import Control.Monad.Fix
21+import Control.Monad.Reader
22+import Control.Monad.Ref
23+import Control.Monad.State.Strict
24+import Data.Align
25+import Data.Dependent.Map (DMap, DSum (..))
26+import qualified Data.Dependent.Map as DMap
27+import Data.Foldable
28+import Data.Functor.Compose
29+import Data.Functor.Misc
30+import Data.Map (Map)
31+import qualified Data.Map as Map
32+import Data.Monoid
33+import Data.Some (Some)
34+import qualified Data.Some as Some
35+import Data.These
36+
37+import Reflex.Class
38+import Reflex.EventWriter
39+import Reflex.Host.Class
40+import Reflex.PerformEvent.Class
41+import Reflex.PostBuild.Class
42+import Reflex.Query.Class
43+import Reflex.Requester.Class
44+import Reflex.TriggerEvent.Class
45+import qualified Reflex.Patch.MapWithMove as MapWithMove
46+
47+newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
48+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)
49+
50+runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
51+runQueryT (QueryT a) qr = do
52+ ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
53+ return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
54+
55+newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
56+
57+getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
58+getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
59+
60+getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
61+getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
62+
63+{-
64+let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
65+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
66+ bs' = fmapCheap snd $ r'
67+ patches = unsafeBuildIncremental (sampleBs bs0) $
68+ flip pushCheap bs' $ \bs -> do
69+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
70+ return (Just (AdditivePatch p))
71+-}
72+
73+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
74+ runWithReplace (QueryT a0) a' = do
75+ ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
76+ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
77+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
78+ bs' = fmapCheap snd $ r'
79+ bbs <- hold bs0 bs'
80+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
81+ oldBs <- sample bbs
82+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
83+ QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
84+ QueryT $ lift $ tellEvent patches
85+ return (r0, fmapCheap fst r')
86+ 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'))
87+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
88+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
89+ f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
90+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
91+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
92+ liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
93+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
94+ liftedBs0 :: Map (Some k) [Behavior t q]
95+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
96+ liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
97+ liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
98+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
99+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
100+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
101+ accumBehaviors :: forall m'. MonadHold t m'
102+ => Map (Some k) [Behavior t q]
103+ -> PatchMap (Some k) [Behavior t q]
104+ -> m' ( Maybe (Map (Some k) [Behavior t q])
105+ , Maybe (AdditivePatch q))
106+ -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
107+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
108+ -- bs0 is a Map denoting the behaviors of the current children.
109+ -- pbs is a PatchMap denoting an update to the behaviors of the current children
110+ accumBehaviors bs0 pbs@(PatchMap bs') = do
111+ let p k bs = case Map.lookup k bs0 of
112+ Nothing -> case bs of
113+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
114+ Nothing -> return mempty
115+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
116+ Just newBs -> sampleBs newBs
117+ Just oldBs -> case bs of
118+ -- 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
119+ Nothing -> negateG <$> sampleBs oldBs
120+ -- 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
121+ -- composed with the sampling the child's new state.
122+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
123+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
124+ -- child patches and wrap them in AdditivePatch.
125+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
126+ return (apply pbs bs0, Just patch)
127+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
128+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
129+ return (liftedResult0, liftedResult')
130+ 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'))
131+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
132+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
133+ f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
134+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
135+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
136+ liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
137+ liftedBs0 :: Map (Some k) [Behavior t q]
138+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
139+ liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
140+ liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
141+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
142+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
143+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
144+ accumBehaviors' :: forall m'. MonadHold t m'
145+ => Map (Some k) [Behavior t q]
146+ -> PatchMapWithMove (Some k) [Behavior t q]
147+ -> m' ( Maybe (Map (Some k) [Behavior t q])
148+ , Maybe (AdditivePatch q))
149+ -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
150+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
151+ -- bs0 is a Map denoting the behaviors of the current children.
152+ -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
153+ accumBehaviors' bs0 pbs = do
154+ let bs' = unPatchMapWithMove pbs
155+ p k bs = case Map.lookup k bs0 of
156+ Nothing -> case MapWithMove._nodeInfo_from bs of
157+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
158+ MapWithMove.From_Delete -> return mempty
159+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
160+ MapWithMove.From_Insert newBs -> sampleBs newBs
161+ MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
162+ Nothing -> return mempty
163+ Just newBs -> sampleBs newBs
164+ Just oldBs -> case MapWithMove._nodeInfo_from bs of
165+ -- 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
166+ MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
167+ -- 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
168+ -- composed with the sampling the child's new state.
169+ MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
170+ MapWithMove.From_Move k'
171+ | k' == k -> return mempty
172+ | otherwise -> case Map.lookup k' bs0 of
173+ -- If we are moving from a non-existent key, that is a delete
174+ Nothing -> negateG <$> sampleBs oldBs
175+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
176+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
177+ -- child patches and wrap them in AdditivePatch.
178+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
179+ return (apply pbs bs0, Just patch)
180+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
181+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
182+ return (liftedResult0, liftedResult')
183+
184+instance MonadTrans (QueryT t q) where
185+ lift = QueryT . lift . lift . lift
186+
187+instance PostBuild t m => PostBuild t (QueryT t q m) where
188+ getPostBuild = lift getPostBuild
189+
190+instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
191+ mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
192+
193+instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
194+ newTriggerEvent = lift newTriggerEvent
195+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
196+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
197+
198+instance PerformEvent t m => PerformEvent t (QueryT t q m) where
199+ type Performable (QueryT t q m) = Performable m
200+ performEvent_ = lift . performEvent_
201+ performEvent = lift . performEvent
202+
203+instance MonadRef m => MonadRef (QueryT t q m) where
204+ type Ref (QueryT t q m) = Ref m
205+ newRef = QueryT . newRef
206+ readRef = QueryT . readRef
207+ writeRef r = QueryT . writeRef r
208+
209+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
210+ newEventWithTrigger = QueryT . newEventWithTrigger
211+ newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
212+
213+mapQuery :: QueryMorphism q q' -> q -> q'
214+mapQuery = _queryMorphism_mapQuery
215+
216+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
217+mapQueryResult = _queryMorphism_mapQueryResult
218+
219+-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
220+withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
221+ => QueryMorphism q q'
222+ -> QueryT t q m a
223+ -> QueryT t q' m a
224+withQueryT f a = do
225+ r' <- askQueryResult
226+ (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
227+ tellQueryIncremental $ unsafeBuildIncremental
228+ (fmap (mapQuery f) (sample (currentIncremental q)))
229+ (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
230+ return result
231+
232+-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
233+dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
234+ => Dynamic t (QueryMorphism q q')
235+ -> QueryT t q m a
236+ -> QueryT t q' m a
237+dynWithQueryT f q = do
238+ r' <- askQueryResult
239+ (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
240+ tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
241+ return result
242+ where zipDynIncrementalWith g da ib =
243+ let eab = align (updated da) (updatedIncremental ib)
244+ ec = flip push eab $ \o -> case o of
245+ This a -> do
246+ aOld <- sample $ current da
247+ b <- sample $ currentIncremental ib
248+ return $ Just $ AdditivePatch (g a b ~~ g aOld b)
249+ That (AdditivePatch b) -> do
250+ a <- sample $ current da
251+ return $ Just $ AdditivePatch $ g a b
252+ These a (AdditivePatch b) -> do
253+ aOld <- sample $ current da
254+ bOld <- sample $ currentIncremental ib
255+ return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
256+ in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
257+
258+instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
259+ tellQueryIncremental q = do
260+ QueryT (modify (currentIncremental q:))
261+ QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
262+ askQueryResult = QueryT ask
263+ queryIncremental q = do
264+ tellQueryIncremental q
265+ r <- askQueryResult
266+ return $ zipDynWith crop (incrementalToDynamic q) r
267+
268+instance Requester t m => Requester t (QueryT t q m) where
269+ type Request (QueryT t q m) = Request m
270+ type Response (QueryT t q m) = Response m
271+ requesting = lift . requesting
272+ requesting_ = lift . requesting_
273+
274+instance EventWriter t w m => EventWriter t w (QueryT t q m) where
275+ tellEvent = lift . tellEvent
src/Reflex/Query/Class.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+module Reflex.Query.Class
10+ ( Query (..)
11+ , QueryMorphism (..)
12+ , SelectedCount (..)
13+ , combineSelectedCounts
14+
15+ , MonadQuery (..)
16+ , tellQueryDyn
17+ , queryDyn
18+ ) where
19+
20+import Control.Monad.Reader
21+import Data.Bits
22+import Data.Data
23+import Data.Ix
24+import Data.Semigroup
25+import Foreign.Storable
26+
27+import Reflex.Class
28+
29+class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
30+ type QueryResult a :: *
31+ crop :: a -> QueryResult a -> QueryResult a
32+
33+-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
34+-- and compatible with the query relationship when acting on the query result
35+data QueryMorphism q q' = QueryMorphism
36+ { _queryMorphism_mapQuery :: q -> q'
37+ , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
38+ }
39+
40+-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
41+newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
42+ deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
43+
44+instance Semigroup SelectedCount where
45+ SelectedCount a <> SelectedCount b = SelectedCount (a + b)
46+
47+instance Monoid SelectedCount where
48+ mempty = SelectedCount 0
49+ mappend = (<>)
50+
51+instance Group SelectedCount where
52+ negateG (SelectedCount a) = SelectedCount (negate a)
53+
54+instance Additive SelectedCount
55+
56+-- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted.
57+combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
58+combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
59+
60+class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
61+ tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
62+ askQueryResult :: m (Dynamic t (QueryResult q))
63+ queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
64+
65+instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
66+ tellQueryIncremental = lift . tellQueryIncremental
67+ askQueryResult = lift askQueryResult
68+ queryIncremental = lift . queryIncremental
69+
70+tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
71+tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
72+
73+queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
74+queryDyn q = do
75+ tellQueryDyn q
76+ r <- askQueryResult
77+ return $ zipDynWith crop q r
src/Reflex/Requester/Base.hsnew file+360
@@ -0,0 +1,360 @@
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+ , traverseRequesterData
29+ ) where
30+
31+import Reflex.Class
32+import Reflex.Dynamic
33+import Reflex.Host.Class
34+import Reflex.PerformEvent.Class
35+import Reflex.PostBuild.Class
36+import Reflex.Requester.Class
37+import Reflex.TriggerEvent.Class
38+
39+import Control.Monad.Exception
40+import Control.Monad.Identity
41+import Control.Monad.Reader
42+import Control.Monad.Ref
43+import Control.Monad.State.Strict
44+import Data.Bits
45+import Data.Coerce
46+import Data.Dependent.Map (DMap)
47+import qualified Data.Dependent.Map as DMap
48+import qualified Data.Some as Some
49+import Data.FastMutableIntMap
50+import Data.Functor.Compose
51+import Data.Functor.Misc
52+import Data.IntMap.Strict (IntMap)
53+import qualified Data.IntMap.Strict as IntMap
54+import Data.Map (Map)
55+import Data.Monoid ((<>))
56+import Data.Unique.Tag
57+import Data.Some (Some)
58+import Data.Tuple
59+import Data.Type.Equality
60+import Data.Proxy
61+
62+import GHC.Exts (Any)
63+import Unsafe.Coerce
64+
65+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
66+
67+newtype RequesterData f = RequesterData (TagMap (Entry f))
68+
69+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
70+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
71+ where
72+ g :: Int -> Any -> t Any
73+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
74+
75+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
76+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
77+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
78+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
79+ go k (Entry request) = Entry <$> case myKeyType k of
80+ MyTagType_Single -> f request
81+ MyTagType_Multi -> traverseRequesterData f request
82+ MyTagType_Multi2 -> traverse (traverseRequesterData f) request
83+ MyTagType_Multi3 -> traverse (traverseRequesterData f) request
84+
85+data MyTagType :: * -> * where
86+ MyTagType_Single :: MyTagType (Single a)
87+ MyTagType_Multi :: MyTagType Multi
88+ MyTagType_Multi2 :: MyTagType (Multi2 k)
89+ MyTagType_Multi3 :: MyTagType Multi3
90+
91+myKeyType :: MyTag x -> MyTagType x
92+myKeyType (MyTag k) = case k .&. 0x3 of
93+ 0x0 -> unsafeCoerce MyTagType_Single
94+ 0x1 -> unsafeCoerce MyTagType_Multi
95+ 0x2 -> unsafeCoerce MyTagType_Multi2
96+ 0x3 -> unsafeCoerce MyTagType_Multi3
97+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
98+
99+data Single a
100+data Multi
101+data Multi2 (k :: * -> *)
102+data Multi3
103+
104+class MyTagTypeOffset x where
105+ myTagTypeOffset :: proxy x -> Int
106+
107+instance MyTagTypeOffset (Single a) where
108+ myTagTypeOffset _ = 0x0
109+
110+instance MyTagTypeOffset Multi where
111+ myTagTypeOffset _ = 0x1
112+
113+instance MyTagTypeOffset (Multi2 k) where
114+ myTagTypeOffset _ = 0x2
115+
116+instance MyTagTypeOffset Multi3 where
117+ myTagTypeOffset _ = 0x3
118+
119+type family EntryContents request a where
120+ EntryContents request (Single a) = request a
121+ EntryContents request Multi = RequesterData request
122+ EntryContents request (Multi2 k) = Map (Some k) (RequesterData request)
123+ EntryContents request Multi3 = IntMap (RequesterData request)
124+
125+newtype Entry request x = Entry { unEntry :: EntryContents request x }
126+
127+{-# INLINE singleEntry #-}
128+singleEntry :: f a -> Entry f (Single a)
129+singleEntry = Entry
130+
131+{-# INLINE multiEntry #-}
132+multiEntry :: RequesterData f -> Entry f Multi
133+multiEntry = Entry
134+
135+-- | 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
136+-- 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
137+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
138+
139+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
140+
141+{-# INLINE castMyTagWrap #-}
142+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
143+castMyTagWrap = coerce
144+
145+instance GEq MyTag where
146+ (MyTag a) `geq` (MyTag b) =
147+ if a == b
148+ then Just $ unsafeCoerce Refl
149+ else Nothing
150+
151+instance GCompare MyTag where
152+ (MyTag a) `gcompare` (MyTag b) =
153+ case a `compare` b of
154+ LT -> GLT
155+ EQ -> unsafeCoerce GEQ
156+ GT -> GGT
157+
158+instance GEq (MyTagWrap f) where
159+ (MyTagWrap a) `geq` (MyTagWrap b) =
160+ if a == b
161+ then Just $ unsafeCoerce Refl
162+ else Nothing
163+
164+instance GCompare (MyTagWrap f) where
165+ (MyTagWrap a) `gcompare` (MyTagWrap b) =
166+ case a `compare` b of
167+ LT -> GLT
168+ EQ -> unsafeCoerce GEQ
169+ GT -> GGT
170+
171+data RequesterState t (request :: * -> *) = RequesterState
172+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
173+ , _requesterState_requests :: ![(Int, Event t Any)]
174+ }
175+
176+-- | A basic implementation of 'Requester'.
177+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
178+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
179+-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
180+#if MIN_VERSION_base(4,9,1)
181+ , MonadAsyncException
182+#endif
183+ )
184+
185+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
186+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
187+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
188+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
189+
190+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
191+-- requests are made, and responses should be provided in the input 'Event'.
192+-- The 'Tag' keys will be used to return the responses to the same place the
193+-- requests were issued.
194+
195+runRequesterT :: (Reflex t, Monad m)
196+ => RequesterT t request response m a
197+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
198+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
199+runRequesterT (RequesterT a) responses = do
200+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
201+ coerceEvent responses
202+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
203+
204+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
205+ type Request (RequesterT t request response m) = request
206+ type Response (RequesterT t request response m) = response
207+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
208+ requesting_ = void . tagRequest . fmapCheap singleEntry
209+
210+{-# INLINE tagRequest #-}
211+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))
212+tagRequest req = do
213+ old <- RequesterT get
214+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
215+ t = MyTagWrap n
216+ RequesterT $ put $ RequesterState
217+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
218+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
219+ }
220+ return t
221+
222+{-# INLINE responseFromTag #-}
223+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
224+responseFromTag (MyTagWrap t) = do
225+ responses :: EventSelectorInt t Any <- RequesterT ask
226+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
227+
228+instance MonadTrans (RequesterT t request response) where
229+ lift = RequesterT . lift . lift
230+
231+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
232+ type Performable (RequesterT t request response m) = Performable m
233+ performEvent_ = lift . performEvent_
234+ performEvent = lift . performEvent
235+
236+instance MonadRef m => MonadRef (RequesterT t request response m) where
237+ type Ref (RequesterT t request response m) = Ref m
238+ newRef = lift . newRef
239+ readRef = lift . readRef
240+ writeRef r = lift . writeRef r
241+
242+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
243+ newEventWithTrigger = lift . newEventWithTrigger
244+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
245+
246+instance MonadReader r m => MonadReader r (RequesterT t request response m) where
247+ ask = lift ask
248+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
249+ reader = lift . reader
250+
251+instance (Reflex t, MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (RequesterT t request response m) where
252+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
253+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
254+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
255+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
256+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
257+
258+requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
259+requesting' = responseFromTag . castMyTagWrap <=< tagRequest
260+
261+{-# INLINABLE runWithReplaceRequesterTWith #-}
262+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
263+ , MonadFix m
264+ )
265+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
266+ -> RequesterT t request response m a
267+ -> Event t (RequesterT t request response m b)
268+ -> RequesterT t request response m (a, Event t b)
269+runWithReplaceRequesterTWith f a0 a' = do
270+ rec response <- fmap (fmapCheap unEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
271+ ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'
272+ requests <- holdDyn requests0 $ fmapCheap snd v'
273+ return (result0, fmapCheap fst v')
274+
275+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
276+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
277+ ( Reflex t
278+ , MonadHold t m
279+ , PatchTarget (p (Event t (RequesterData request))) ~ IntMap (Event t (RequesterData request))
280+ , Patch (p (Event t (RequesterData request)))
281+ , Functor p
282+ , MonadFix m
283+ )
284+ => ( (IntMap.Key -> v -> m (Event t (RequesterData request), v'))
285+ -> IntMap v
286+ -> Event t (p v)
287+ -> RequesterT t request response m (IntMap (Event t (RequesterData request), v'), Event t (p (Event t (RequesterData request), v')))
288+ )
289+ -> (p (Event t (RequesterData request)) -> IntMap (Event t (RequesterData request)))
290+ -> (Incremental t (p (Event t (RequesterData request))) -> Event t (IntMap (RequesterData request)))
291+ -> (IntMap.Key -> v -> RequesterT t request response m v')
292+ -> IntMap v
293+ -> Event t (p v)
294+ -> RequesterT t request response m (IntMap v', Event t (p v'))
295+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
296+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
297+ let responses :: EventSelectorInt t (RequesterData response)
298+ responses = fanInt $ fmapCheap unpack response
299+ unpack :: Entry response Multi3 -> IntMap (RequesterData response)
300+ unpack = unEntry
301+ pack :: IntMap (RequesterData request) -> Entry request Multi3
302+ pack = Entry
303+ f' :: IntMap.Key -> v -> m (Event t (RequesterData request), v')
304+ f' k v = fmap swap $ runRequesterT (f k v) $ selectInt responses k
305+ (children0, children') <- base f' dm0 dm'
306+ let result0 = fmap snd children0
307+ result' = fforCheap children' $ fmap snd
308+ requests0 :: IntMap (Event t (RequesterData request))
309+ requests0 = fmap fst children0
310+ requests' :: Event t (p (Event t (RequesterData request)))
311+ requests' = fforCheap children' $ fmap fst
312+ promptRequests :: Event t (IntMap (RequesterData request))
313+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
314+ requests <- holdIncremental requests0 requests'
315+ return (result0, result')
316+
317+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
318+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
319+ ( GCompare k
320+ , Reflex t
321+ , MonadHold t m
322+ , PatchTarget (p' (Some k) (Event t (RequesterData request))) ~ Map (Some k) (Event t (RequesterData request))
323+ , Patch (p' (Some k) (Event t (RequesterData request)))
324+ , MonadFix m
325+ )
326+ => (forall k' v1 v2. GCompare k'
327+ => (forall a. k' a -> v1 a -> m (v2 a))
328+ -> DMap k' v1
329+ -> Event t (p k' v1)
330+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
331+ )
332+ -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')
333+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
334+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
335+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
336+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
337+ -> DMap k v
338+ -> Event t (p k v)
339+ -> RequesterT t request response m (DMap k v', Event t (p k v'))
340+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
341+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
342+ let responses :: EventSelector t (Const2 (Some k) (RequesterData response))
343+ responses = fanMap $ fmapCheap unpack response
344+ unpack :: Entry response (Multi2 k) -> Map (Some k) (RequesterData response)
345+ unpack = unEntry
346+ pack :: Map (Some k) (RequesterData request) -> Entry request (Multi2 k)
347+ pack = Entry
348+ f' :: forall a. k a -> v a -> m (Compose ((,) (Event t (RequesterData request))) v' a)
349+ f' k v = fmap (Compose . swap) $ runRequesterT (f k v) $ select responses (Const2 (Some.This k))
350+ (children0, children') <- base f' dm0 dm'
351+ let result0 = DMap.map (snd . getCompose) children0
352+ result' = fforCheap children' $ mapPatch $ snd . getCompose
353+ requests0 :: Map (Some k) (Event t (RequesterData request))
354+ requests0 = weakenDMapWith (fst . getCompose) children0
355+ requests' :: Event t (p' (Some k) (Event t (RequesterData request)))
356+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
357+ promptRequests :: Event t (Map (Some k) (RequesterData request))
358+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
359+ requests <- holdIncremental requests0 requests'
360+ 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+22
@@ -0,0 +1,22 @@
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+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
11+ , runSpiderHostForTimeline
12+ , newSpiderTimeline
13+ , withSpiderTimeline
14+#endif
15+ -- * Deprecated
16+ , SpiderEnv
17+ ) where
18+
19+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
20+import Reflex.Class
21+#endif
22+import Reflex.Spider.Internal
src/Reflex/Spider/Internal.hsnew file+2428
@@ -0,0 +1,2428 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE ExistentialQuantification #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE GADTs #-}
10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11+{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MagicHash #-}
13+{-# LANGUAGE MultiParamTypeClasses #-}
14+{-# LANGUAGE MultiWayIf #-}
15+{-# LANGUAGE RankNTypes #-}
16+{-# LANGUAGE RoleAnnotations #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+{-# LANGUAGE TypeFamilies #-}
19+{-# LANGUAGE TypeOperators #-}
20+{-# LANGUAGE UndecidableInstances #-}
21+#ifdef USE_REFLEX_OPTIMIZER
22+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
23+#endif
24+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
25+{-# OPTIONS_GHC -fno-warn-orphans #-}
26+#endif
27+-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
28+-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
29+module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
30+
31+import Control.Applicative
32+import Control.Concurrent
33+import Control.Exception
34+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
35+import Control.Monad.Exception
36+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)
37+import Control.Monad.Primitive
38+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
39+import Control.Monad.Ref
40+import Data.Align
41+import Data.Coerce
42+import Data.Dependent.Map (DMap, DSum (..))
43+import qualified Data.Dependent.Map as DMap
44+import Data.Foldable hiding (concat, elem, sequence_)
45+import Data.Function
46+import Data.Functor.Constant
47+import Data.Functor.Misc
48+import Data.Functor.Product
49+import Data.GADT.Compare
50+import Data.IntMap.Strict (IntMap)
51+import qualified Data.IntMap.Strict as IntMap
52+import Data.IORef
53+import Data.List hiding (foldl')
54+import Data.Maybe
55+import Data.Monoid ((<>))
56+import Data.Proxy
57+import Data.These
58+import Data.Traversable
59+import Data.Word
60+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
61+import qualified Data.FastMutableIntMap as FastMutableIntMap
62+import GHC.Exts
63+import GHC.IORef (IORef (..))
64+import GHC.Stack
65+import Reflex.FastWeak
66+import Reflex.FunctorMaybe
67+import System.IO.Unsafe
68+import System.Mem.Weak
69+import Unsafe.Coerce
70+
71+#ifdef DEBUG_CYCLES
72+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
73+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
74+import qualified Data.List.NonEmpty as NonEmpty
75+import Data.Monoid (mempty)
76+import Data.Tree (Forest, Tree (..), drawForest)
77+#endif
78+
79+import Data.FastWeakBag (FastWeakBag)
80+import qualified Data.FastWeakBag as FastWeakBag
81+import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
82+import qualified Data.WeakBag as WeakBag
83+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
84+import Data.Reflection
85+import Data.Some (Some)
86+import qualified Data.Some as Some
87+import Data.Type.Coercion
88+import qualified Reflex.Class
89+import qualified Reflex.Class as R
90+import qualified Reflex.Host.Class
91+#endif
92+import Reflex.Patch
93+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
94+
95+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
96+import Prelude hiding (any, concat, mapM, mapM_, sequence)
97+
98+#ifdef DEBUG_TRACE_EVENTS
99+import System.IO (stderr)
100+import qualified Data.ByteString.Char8 as BS8
101+#endif
102+
103+#ifdef DEBUG_TRACE_EVENTS
104+
105+withStackOneLine :: (BS8.ByteString -> a) -> a
106+withStackOneLine expr = unsafePerformIO $ do
107+ stack <- currentCallStack
108+ return (expr (BS8.pack (unwords (reverse stack))))
109+
110+#endif
111+
112+debugPropagate :: Bool
113+
114+debugInvalidateHeight :: Bool
115+
116+debugInvalidate :: Bool
117+
118+#ifdef DEBUG
119+
120+#define DEBUG_NODEIDS
121+
122+debugPropagate = True
123+
124+debugInvalidateHeight = False
125+
126+debugInvalidate = True
127+
128+class HasNodeId a where
129+ getNodeId :: a -> Int
130+
131+instance HasNodeId (Hold x p a) where
132+ getNodeId = holdNodeId
133+
134+instance HasNodeId (PushSubscribed x a b) where
135+ getNodeId = pushSubscribedNodeId
136+
137+instance HasNodeId (SwitchSubscribed x a) where
138+ getNodeId = switchSubscribedNodeId
139+
140+instance HasNodeId (FanSubscribed x a) where
141+ getNodeId = fanSubscribedNodeId
142+
143+instance HasNodeId (CoincidenceSubscribed x a) where
144+ getNodeId = coincidenceSubscribedNodeId
145+
146+instance HasNodeId (RootSubscribed x a) where
147+ getNodeId = rootSubscribedNodeId
148+
149+instance HasNodeId (Pull x a) where
150+ getNodeId = pullNodeId
151+
152+{-# INLINE showNodeId #-}
153+showNodeId :: HasNodeId a => a -> String
154+showNodeId = ("#"<>) . show . getNodeId
155+
156+showSubscriberType :: Subscriber x a -> String
157+showSubscriberType = \case
158+ SubscriberPush _ _ -> "SubscriberPush"
159+ SubscriberMerge _ _ -> "SubscriberMerge"
160+ SubscriberFan _ -> "SubscriberFan"
161+ SubscriberMergeChange _ -> "SubscriberMergeChange"
162+ SubscriberHold _ -> "SubscriberHold"
163+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
164+ SubscriberSwitch _ -> "SubscriberSwitch"
165+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
166+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
167+ SubscriberHandle -> "SubscriberHandle"
168+
169+showEventType :: Event x a -> String
170+showEventType = \case
171+ EventRoot _ _ -> "EventRoot"
172+ EventNever -> "EventNever"
173+ EventPush _ -> "EventPush"
174+ EventMerge _ -> "EventMerge"
175+ EventFan _ _ -> "EventFan"
176+ EventSwitch _ -> "EventSwitch"
177+ EventCoincidence _ -> "EventCoincidence"
178+ EventHold _ -> "EventHold"
179+ EventDyn _ -> "EventDyn"
180+ EventHoldIdentity _ -> "EventHoldIdentity"
181+ EventDynIdentity _ -> "EventDynIdentity"
182+
183+#else
184+
185+debugPropagate = False
186+
187+debugInvalidateHeight = False
188+
189+debugInvalidate = False
190+
191+-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
192+{-# INLINE showNodeId #-}
193+showNodeId :: a -> String
194+showNodeId _ = ""
195+
196+#endif
197+
198+#ifdef DEBUG_NODEIDS
199+{-# NOINLINE nextNodeIdRef #-}
200+nextNodeIdRef :: IORef Int
201+nextNodeIdRef = unsafePerformIO $ newIORef 1
202+
203+newNodeId :: IO Int
204+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
205+
206+{-# NOINLINE unsafeNodeId #-}
207+unsafeNodeId :: a -> Int
208+unsafeNodeId a = unsafePerformIO $ do
209+ touch a
210+ newNodeId
211+#endif
212+
213+--------------------------------------------------------------------------------
214+-- EventSubscription
215+--------------------------------------------------------------------------------
216+
217+--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
218+-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
219+data EventSubscription x = EventSubscription
220+ { _eventSubscription_unsubscribe :: !(IO ())
221+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
222+ }
223+
224+unsubscribe :: EventSubscription x -> IO ()
225+unsubscribe (EventSubscription u _) = u
226+
227+--------------------------------------------------------------------------------
228+-- Event
229+--------------------------------------------------------------------------------
230+
231+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
232+
233+{-# INLINE subscribeAndRead #-}
234+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
235+subscribeAndRead = unEvent
236+
237+{-# RULES
238+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
239+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
240+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
241+ #-}
242+
243+-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
244+-- caching; if the computation function is very cheap, this is (much) more
245+-- efficient than 'push'
246+{-# INLINE [1] pushCheap #-}
247+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
248+pushCheap !f e = Event $ \sub -> do
249+ (subscription, occ) <- subscribeAndRead e $ sub
250+ { subscriberPropagate = \a -> do
251+ mb <- f a
252+ mapM_ (subscriberPropagate sub) mb
253+ }
254+ occ' <- join <$> mapM f occ
255+ return (subscription, occ')
256+
257+data CacheSubscribed x a
258+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
259+ , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
260+ , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
261+ }
262+
263+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
264+-- repeatedly
265+--
266+--TODO: Try a caching strategy where we subscribe directly to the parent when
267+--there's only one subscriber, and then build our own FastWeakBag only when a second
268+--subscriber joins
269+{-# NOINLINE cacheEvent #-}
270+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
271+cacheEvent e =
272+#ifdef DEBUG_TRACE_EVENTS
273+ withStackOneLine $ \callSite -> Event $
274+#else
275+ Event $
276+#endif
277+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
278+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
279+ in \sub -> {-# SCC "cacheEvent" #-} do
280+#ifdef DEBUG_TRACE_EVENTS
281+ unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
282+#endif
283+ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
284+ Just subscribedTicket -> return subscribedTicket
285+ Nothing -> do
286+ subscribers <- liftIO FastWeakBag.empty
287+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
288+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
289+ { subscriberPropagate = \a -> do
290+ liftIO $ writeIORef occRef $ Just a
291+ scheduleClear occRef
292+ propagateFast a subscribers
293+ , subscriberInvalidateHeight = \old -> do
294+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
295+ , subscriberRecalculateHeight = \new -> do
296+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
297+ }
298+ when (isJust occ) $ do
299+ liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
300+ scheduleClear occRef
301+ let !subscribed = CacheSubscribed
302+ { _cacheSubscribed_subscribers = subscribers
303+ , _cacheSubscribed_parent = parentSub
304+ , _cacheSubscribed_occurrence = occRef
305+ }
306+ subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
307+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
308+ return subscribedTicket
309+ liftIO $ do
310+ subscribed <- getFastWeakTicketValue subscribedTicket
311+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
312+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
313+ let es = EventSubscription
314+ { _eventSubscription_unsubscribe = do
315+ FastWeakBag.remove ticket
316+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
317+ when isEmpty $ do
318+ writeIORef mSubscribedRef emptyFastWeak
319+ unsubscribe $ _cacheSubscribed_parent subscribed
320+ touch ticket
321+ touch subscribedTicket
322+ , _eventSubscription_subscribed = EventSubscribed
323+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
324+ , eventSubscribedRetained = toAny subscribedTicket
325+ }
326+ }
327+ return (es, occ)
328+
329+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
330+subscribe e s = fst <$> subscribeAndRead e s
331+
332+{-# INLINE wrap #-}
333+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
334+wrap tag getSpecificSubscribed sub = do
335+ (sln, subd, occ) <- getSpecificSubscribed sub
336+ let es = tag subd
337+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
338+
339+eventRoot :: GCompare k => k a -> Root x k -> Event x a
340+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
341+
342+eventNever :: Event x a
343+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
344+
345+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
346+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
347+
348+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
349+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
350+
351+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
352+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
353+
354+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
355+eventHold !h = Event $ subscribeHoldEvent h
356+
357+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
358+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
359+
360+{-# INLINE subscribeCoincidenceInner #-}
361+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)
362+subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
363+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
364+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
365+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
366+ let height = max innerHeight outerHeight
367+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
368+ return (innerOcc, height, innerSubd)
369+
370+--------------------------------------------------------------------------------
371+-- Subscriber
372+--------------------------------------------------------------------------------
373+
374+data Subscriber x a = Subscriber
375+ { subscriberPropagate :: !(a -> EventM x ())
376+ , subscriberInvalidateHeight :: !(Height -> IO ())
377+ , subscriberRecalculateHeight :: !(Height -> IO ())
378+ }
379+
380+--TODO: Move this comment to WeakBag
381+-- These function are constructor functions that are marked NOINLINE so they are
382+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
383+-- so any weak references that are attached to the constructors will have their
384+-- finalizer run. Using the opaque constructor, does not see the
385+-- constructor application, so it behaves like an IORef and cannot be fused away.
386+--
387+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
388+-- the weak pointer to it in some cases.
389+
390+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
391+newSubscriberHold h = return $ Subscriber
392+ { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
393+ , subscriberInvalidateHeight = \_ -> return ()
394+ , subscriberRecalculateHeight = \_ -> return ()
395+ }
396+
397+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
398+newSubscriberFan subscribed = return $ Subscriber
399+ { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
400+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
401+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
402+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
403+ scheduleClear $ fanSubscribedOccurrence subscribed
404+ let f _ (Pair (Identity v) subsubs) = do
405+ propagate v $ _fanSubscribedChildren_list subsubs
406+ return $ Constant ()
407+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
408+ return ()
409+ , subscriberInvalidateHeight = \old -> do
410+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
411+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
412+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
413+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
414+ , subscriberRecalculateHeight = \new -> do
415+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
416+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
417+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
418+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
419+ }
420+
421+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
422+newSubscriberSwitch subscribed = return $ Subscriber
423+ { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
424+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
425+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
426+ scheduleClear $ switchSubscribedOccurrence subscribed
427+ propagate a $ switchSubscribedSubscribers subscribed
428+ , subscriberInvalidateHeight = \_ -> do
429+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
430+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
431+ when (oldHeight /= invalidHeight) $ do
432+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
433+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
434+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
435+ , subscriberRecalculateHeight = \new -> do
436+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
437+ updateSwitchHeight new subscribed
438+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
439+ }
440+
441+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
442+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
443+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
444+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
445+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
446+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
447+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
448+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
449+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
450+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
451+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
452+ case occ of
453+ Nothing -> do
454+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
455+ writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
456+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
457+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
458+ Just o -> do -- Since it's already firing, no need to adjust height
459+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
460+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
461+ propagate o $ coincidenceSubscribedSubscribers subscribed
462+ , subscriberInvalidateHeight = \_ -> do
463+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
464+ invalidateCoincidenceHeight subscribed
465+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
466+ , subscriberRecalculateHeight = \_ -> do
467+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
468+ recalculateCoincidenceHeight subscribed
469+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
470+ }
471+
472+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
473+newSubscriberCoincidenceInner subscribed = return $ Subscriber
474+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
475+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
476+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
477+ case occ of
478+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
479+ Nothing -> do
480+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
481+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
482+ propagate a $ coincidenceSubscribedSubscribers subscribed
483+ , subscriberInvalidateHeight = \_ -> do
484+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
485+ invalidateCoincidenceHeight subscribed
486+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
487+ , subscriberRecalculateHeight = \_ -> do
488+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
489+ recalculateCoincidenceHeight subscribed
490+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
491+ }
492+
493+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
494+invalidateSubscriberHeight = flip subscriberInvalidateHeight
495+
496+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
497+recalculateSubscriberHeight = flip subscriberRecalculateHeight
498+
499+-- | Propagate everything at the current height
500+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
501+propagate a subscribers = withIncreasedDepth $ do
502+ -- 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
503+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
504+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
505+
506+-- | Propagate everything at the current height
507+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
508+propagateFast a subscribers = withIncreasedDepth $ do
509+ -- 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
510+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
511+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
512+
513+--------------------------------------------------------------------------------
514+-- EventSubscribed
515+--------------------------------------------------------------------------------
516+
517+toAny :: a -> Any
518+toAny = unsafeCoerce
519+
520+data EventSubscribed x = EventSubscribed
521+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
522+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
523+#ifdef DEBUG_CYCLES
524+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
525+ , eventSubscribedHasOwnHeightRef :: !Bool
526+ , eventSubscribedWhoCreated :: !(IO [String])
527+#endif
528+ }
529+
530+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
531+eventSubscribedRoot !r = EventSubscribed
532+ { eventSubscribedHeightRef = zeroRef
533+ , eventSubscribedRetained = toAny r
534+#ifdef DEBUG_CYCLES
535+ , eventSubscribedGetParents = return []
536+ , eventSubscribedHasOwnHeightRef = False
537+ , eventSubscribedWhoCreated = return ["root"]
538+#endif
539+ }
540+
541+eventSubscribedNever :: EventSubscribed x
542+eventSubscribedNever = EventSubscribed
543+ { eventSubscribedHeightRef = zeroRef
544+ , eventSubscribedRetained = toAny ()
545+#ifdef DEBUG_CYCLES
546+ , eventSubscribedGetParents = return []
547+ , eventSubscribedHasOwnHeightRef = False
548+ , eventSubscribedWhoCreated = return ["never"]
549+#endif
550+ }
551+
552+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
553+eventSubscribedFan !subscribed = EventSubscribed
554+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
555+ , eventSubscribedRetained = toAny subscribed
556+#ifdef DEBUG_CYCLES
557+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
558+ , eventSubscribedHasOwnHeightRef = False
559+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
560+#endif
561+ }
562+
563+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
564+eventSubscribedSwitch !subscribed = EventSubscribed
565+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
566+ , eventSubscribedRetained = toAny subscribed
567+#ifdef DEBUG_CYCLES
568+ , eventSubscribedGetParents = do
569+ s <- readIORef $ switchSubscribedCurrentParent subscribed
570+ return [Some.This $ _eventSubscription_subscribed s]
571+ , eventSubscribedHasOwnHeightRef = True
572+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
573+#endif
574+ }
575+
576+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
577+eventSubscribedCoincidence !subscribed = EventSubscribed
578+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
579+ , eventSubscribedRetained = toAny subscribed
580+#ifdef DEBUG_CYCLES
581+ , eventSubscribedGetParents = do
582+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
583+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
584+ innerParents = maybeToList $ fmap Some.This innerSubscription
585+ return $ outerParent : innerParents
586+ , eventSubscribedHasOwnHeightRef = True
587+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
588+#endif
589+ }
590+
591+getEventSubscribedHeight :: EventSubscribed x -> IO Height
592+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
593+
594+#ifdef DEBUG_CYCLES
595+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
596+whoCreatedEventSubscribed = eventSubscribedWhoCreated
597+
598+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
599+walkInvalidHeightParents s0 = do
600+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
601+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
602+ when (h == invalidHeight) $ do
603+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
604+ modify (Some.This s :)
605+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
606+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
607+ return subscribers
608+#endif
609+
610+{-# INLINE subscribeHoldEvent #-}
611+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
612+subscribeHoldEvent = subscribeAndRead . holdEvent
613+
614+--------------------------------------------------------------------------------
615+-- Behavior
616+--------------------------------------------------------------------------------
617+
618+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
619+
620+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
621+behaviorHold !h = Behavior $ readHoldTracked h
622+
623+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
624+behaviorHoldIdentity = behaviorHold
625+
626+behaviorConst :: a -> Behavior x a
627+behaviorConst !a = Behavior $ return a
628+
629+behaviorPull :: Pull x a -> Behavior x a
630+behaviorPull !p = Behavior $ do
631+ val <- liftIO $ readIORef $ pullValue p
632+ case val of
633+ Just subscribed -> do
634+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
635+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
636+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
637+ return $ pullSubscribedValue subscribed
638+ Nothing -> do
639+ i <- liftIO $ newInvalidatorPull p
640+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
641+ parentsRef <- liftIO $ newIORef []
642+ holdInits <- askBehaviorHoldInits
643+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
644+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
645+ parents <- liftIO $ readIORef parentsRef
646+ let subscribed = PullSubscribed
647+ { pullSubscribedValue = a
648+ , pullSubscribedInvalidators = invsRef
649+ , pullSubscribedOwnInvalidator = i
650+ , pullSubscribedParents = parents
651+ }
652+ liftIO $ writeIORef (pullValue p) $ Just subscribed
653+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
654+ return a
655+
656+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
657+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
658+
659+{-# INLINE readHoldTracked #-}
660+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
661+readHoldTracked h = do
662+ result <- liftIO $ readIORef $ holdValue h
663+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
664+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
665+ return result
666+
667+{-# INLINABLE readBehaviorUntracked #-}
668+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
669+readBehaviorUntracked b = do
670+ holdInits <- getDeferralQueue
671+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
672+
673+--------------------------------------------------------------------------------
674+-- Dynamic
675+--------------------------------------------------------------------------------
676+
677+data Dynamic x p = Dynamic
678+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
679+ , dynamicUpdated :: !(Event x p)
680+ }
681+
682+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
683+dynamicHold !h = Dynamic
684+ { dynamicCurrent = behaviorHold h
685+ , dynamicUpdated = eventHold h
686+ }
687+
688+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
689+dynamicHoldIdentity = dynamicHold
690+
691+dynamicConst :: PatchTarget p -> Dynamic x p
692+dynamicConst !a = Dynamic
693+ { dynamicCurrent = behaviorConst a
694+ , dynamicUpdated = eventNever
695+ }
696+
697+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
698+dynamicDyn !d = Dynamic
699+ { dynamicCurrent = behaviorDyn d
700+ , dynamicUpdated = eventDyn d
701+ }
702+
703+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
704+dynamicDynIdentity = dynamicDyn
705+
706+--------------------------------------------------------------------------------
707+-- Combinators
708+--------------------------------------------------------------------------------
709+
710+--TODO: Figure out why certain things are not 'representational', then make them
711+--representational so we can use coerce
712+
713+--type role Hold representational
714+data Hold x p
715+ = Hold { holdValue :: !(IORef (PatchTarget p))
716+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
717+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
718+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
719+#ifdef DEBUG_NODEIDS
720+ , holdNodeId :: Int
721+#endif
722+ }
723+
724+-- | A statically allocated 'SpiderTimeline'; this is the only instance of
725+-- 'SpiderTimeline' that can used when using
726+-- -fspecialize-to-spidertimeline-global.
727+data Global
728+
729+{-# NOINLINE globalSpiderTimelineEnv #-}
730+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
731+globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
732+
733+-- | Stores all global data relevant to a particular Spider timeline; only one
734+-- value should exist for each type @x@
735+data SpiderTimelineEnv x = SpiderTimelineEnv
736+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
737+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
738+#ifdef DEBUG
739+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
740+#endif
741+ }
742+type role SpiderTimelineEnv nominal
743+
744+instance Eq (SpiderTimelineEnv x) where
745+ _ == _ = True -- Since only one exists of each type
746+
747+instance GEq SpiderTimelineEnv where
748+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
749+ geqToEq _ = id
750+ geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b
751+ then case unsafeCoerce Refl :: a :~: b of
752+ Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
753+ else different
754+#else
755+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
756+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
757+ else Nothing
758+#endif
759+
760+data EventEnv x
761+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
762+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
763+ , eventEnvDynInits :: !(IORef [SomeDynInit x])
764+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
765+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
766+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
767+ , eventEnvIntClears :: !(IORef [SomeIntClear])
768+ , eventEnvRootClears :: !(IORef [SomeRootClear])
769+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
770+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
771+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
772+ }
773+
774+{-# INLINE runEventM #-}
775+runEventM :: EventM x a -> IO a
776+runEventM = unEventM
777+
778+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
779+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
780+
781+class MonadIO m => Defer a m where
782+ getDeferralQueue :: m (IORef [a])
783+
784+{-# INLINE defer #-}
785+defer :: Defer a m => a -> m ()
786+defer a = do
787+ q <- getDeferralQueue
788+ liftIO $ modifyIORef' q (a:)
789+
790+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
791+ {-# INLINE getDeferralQueue #-}
792+ getDeferralQueue = asksEventEnv eventEnvAssignments
793+
794+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
795+ {-# INLINE getDeferralQueue #-}
796+ getDeferralQueue = asksEventEnv eventEnvHoldInits
797+
798+instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
799+ {-# INLINE getDeferralQueue #-}
800+ getDeferralQueue = asksEventEnv eventEnvDynInits
801+
802+instance Defer (SomeHoldInit x) (BehaviorM x) where
803+ {-# INLINE getDeferralQueue #-}
804+ getDeferralQueue = BehaviorM $ asks snd
805+
806+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
807+ {-# INLINE getDeferralQueue #-}
808+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
809+
810+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
811+ {-# INLINE getDeferralQueue #-}
812+ getDeferralQueue = asksEventEnv eventEnvMergeInits
813+
814+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
815+ getCurrentHeight :: m Height
816+ scheduleMerge :: Height -> EventM x () -> m ()
817+
818+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
819+ {-# INLINE getCurrentHeight #-}
820+ getCurrentHeight = do
821+ heightRef <- asksEventEnv eventEnvCurrentHeight
822+ liftIO $ readIORef heightRef
823+ {-# INLINE scheduleMerge #-}
824+ scheduleMerge height subscribed = do
825+ delayedRef <- asksEventEnv eventEnvDelayedMerges
826+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
827+
828+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
829+class x ~ Global => HasSpiderTimeline x where
830+#else
831+class HasSpiderTimeline x where
832+#endif
833+ -- | Retrieve the current SpiderTimelineEnv
834+ spiderTimeline :: SpiderTimelineEnv x
835+
836+instance HasSpiderTimeline Global where
837+ spiderTimeline = globalSpiderTimelineEnv
838+
839+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
840+putCurrentHeight h = do
841+ heightRef <- asksEventEnv eventEnvCurrentHeight
842+ liftIO $ writeIORef heightRef $! h
843+
844+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
845+ {-# INLINE getDeferralQueue #-}
846+ getDeferralQueue = asksEventEnv eventEnvClears
847+
848+{-# INLINE scheduleClear #-}
849+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
850+scheduleClear r = defer $ SomeClear r
851+
852+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
853+ {-# INLINE getDeferralQueue #-}
854+ getDeferralQueue = asksEventEnv eventEnvIntClears
855+
856+{-# INLINE scheduleIntClear #-}
857+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
858+scheduleIntClear r = defer $ SomeIntClear r
859+
860+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
861+ {-# INLINE getDeferralQueue #-}
862+ getDeferralQueue = asksEventEnv eventEnvRootClears
863+
864+{-# INLINE scheduleRootClear #-}
865+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
866+scheduleRootClear r = defer $ SomeRootClear r
867+
868+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
869+ {-# INLINE getDeferralQueue #-}
870+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
871+
872+-- Note: hold cannot examine its event until after the phase is over
873+{-# INLINE [1] hold #-}
874+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
875+hold v0 e = do
876+ valRef <- liftIO $ newIORef v0
877+ invsRef <- liftIO $ newIORef []
878+ parentRef <- liftIO $ newIORef Nothing
879+#ifdef DEBUG_NODEIDS
880+ nodeId <- liftIO newNodeId
881+#endif
882+ let h = Hold
883+ { holdValue = valRef
884+ , holdInvalidators = invsRef
885+ , holdEvent = e
886+ , holdParent = parentRef
887+#ifdef DEBUG_NODEIDS
888+ , holdNodeId = nodeId
889+#endif
890+ }
891+ defer $ SomeHoldInit h
892+ return h
893+
894+{-# INLINE getHoldEventSubscription #-}
895+getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Hold x p -> m (EventSubscription x)
896+getHoldEventSubscription h = do
897+ ep <- liftIO $ readIORef $ holdParent h
898+ case ep of
899+ Just subd -> return subd
900+ Nothing -> do
901+ let e = holdEvent h
902+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
903+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
904+ liftIO $ writeIORef subscriptionRef $! subscription
905+ case occ of
906+ Nothing -> return ()
907+ Just o -> do
908+ old <- liftIO $ readIORef $ holdValue h
909+ case apply o old of
910+ Nothing -> return ()
911+ Just new -> do
912+ -- Need to evaluate these so that we don't retain the Hold itself
913+ v <- liftIO $ evaluate $ holdValue h
914+ i <- liftIO $ evaluate $ holdInvalidators h
915+ defer $ SomeAssignment v i new
916+ liftIO $ writeIORef (holdParent h) $ Just subscription
917+ return subscription
918+
919+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
920+
921+--type role BehaviorM representational
922+-- BehaviorM can sample behaviors
923+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
924+
925+instance Monad (BehaviorM x) where
926+ {-# INLINE (>>=) #-}
927+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
928+ {-# INLINE (>>) #-}
929+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
930+ {-# INLINE return #-}
931+ return x = BehaviorM $ return x
932+ {-# INLINE fail #-}
933+ fail s = BehaviorM $ fail s
934+
935+data BehaviorSubscribed x a
936+ = forall p. BehaviorSubscribedHold (Hold x p)
937+ | BehaviorSubscribedPull (PullSubscribed x a)
938+
939+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
940+
941+--type role PullSubscribed representational
942+data PullSubscribed x a
943+ = PullSubscribed { pullSubscribedValue :: !a
944+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
945+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
946+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
947+ }
948+
949+--type role Pull representational
950+data Pull x a
951+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
952+ , pullCompute :: !(BehaviorM x a)
953+#ifdef DEBUG_NODEIDS
954+ , pullNodeId :: Int
955+#endif
956+ }
957+
958+data Invalidator x
959+ = forall a. InvalidatorPull (Pull x a)
960+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
961+
962+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
963+ { rootSubscribedKey :: !(k a)
964+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
965+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
966+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
967+ , rootSubscribedUninit :: IO ()
968+ , 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?
969+#ifdef DEBUG_NODEIDS
970+ , rootSubscribedNodeId :: Int
971+#endif
972+ }
973+
974+data Root x (k :: * -> *)
975+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
976+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
977+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
978+ }
979+
980+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
981+
982+data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
983+
984+data SomeMergeUpdate x = SomeMergeUpdate
985+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
986+ , _someMergeUpdate_invalidateHeight :: !(IO ())
987+ , _someMergeUpdate_recalculateHeight :: !(IO ())
988+ }
989+
990+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
991+
992+-- EventM can do everything BehaviorM can, plus create holds
993+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
994+
995+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
996+
997+data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
998+ { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
999+ , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1000+ }
1001+
1002+data HeightBag = HeightBag
1003+ { _heightBag_size :: {-# UNPACK #-} !Int
1004+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1005+ }
1006+ deriving (Show, Read, Eq, Ord)
1007+
1008+heightBagEmpty :: HeightBag
1009+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1010+
1011+heightBagSize :: HeightBag -> Int
1012+heightBagSize = _heightBag_size
1013+
1014+heightBagFromList :: [Height] -> HeightBag
1015+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1016+
1017+heightBagAdd :: Height -> HeightBag -> HeightBag
1018+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1019+
1020+heightBagRemove :: Height -> HeightBag -> HeightBag
1021+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1022+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1023+ Just old -> HeightBag (pred s) $ case old of
1024+ 0 -> IntMap.delete h c
1025+ _ -> IntMap.insert h (pred old) c
1026+
1027+heightBagMax :: HeightBag -> Height
1028+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1029+ Just ((h, _), _) -> Height h
1030+ Nothing -> zeroHeight
1031+
1032+heightBagVerify :: HeightBag -> HeightBag
1033+#ifdef DEBUG
1034+heightBagVerify b@(HeightBag s c) = if
1035+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1036+ -> error $ "heightBagVerify: size doesn't match: " <> show b
1037+ | unHeight invalidHeight `IntMap.member` c
1038+ -> error $ "heightBagVerify: contains invalid height: " <> show b
1039+ | otherwise -> b
1040+#else
1041+heightBagVerify = id
1042+#endif
1043+
1044+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1045+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1046+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1047+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1048+ }
1049+
1050+data FanSubscribed (x :: *) k
1051+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1052+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1053+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1054+ , fanSubscribedParent :: !(EventSubscription x)
1055+#ifdef DEBUG_NODEIDS
1056+ , fanSubscribedNodeId :: Int
1057+#endif
1058+ }
1059+
1060+data Fan x k
1061+ = Fan { fanParent :: !(Event x (DMap k Identity))
1062+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1063+ }
1064+
1065+data SwitchSubscribed x a
1066+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1067+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
1068+ , switchSubscribedHeight :: !(IORef Height)
1069+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1070+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1071+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1072+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1073+ , switchSubscribedParent :: !(Behavior x (Event x a))
1074+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1075+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1076+#ifdef DEBUG_NODEIDS
1077+ , switchSubscribedNodeId :: Int
1078+#endif
1079+ }
1080+
1081+data Switch x a
1082+ = Switch { switchParent :: !(Behavior x (Event x a))
1083+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1084+ }
1085+
1086+#ifdef USE_TEMPLATE_HASKELL
1087+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1088+#endif
1089+data CoincidenceSubscribed x a
1090+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1091+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1092+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1093+ , coincidenceSubscribedHeight :: !(IORef Height)
1094+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1095+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1096+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1097+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1098+#ifdef DEBUG_NODEIDS
1099+ , coincidenceSubscribedNodeId :: Int
1100+#endif
1101+ }
1102+
1103+data Coincidence x a
1104+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1105+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1106+ }
1107+
1108+{-# NOINLINE newInvalidatorSwitch #-}
1109+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1110+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1111+
1112+{-# NOINLINE newInvalidatorPull #-}
1113+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1114+newInvalidatorPull p = return $! InvalidatorPull p
1115+
1116+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1117+ fmapMaybe f = push $ return . f
1118+
1119+instance HasSpiderTimeline x => Align (Event x) where
1120+ nil = eventNever
1121+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1122+
1123+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1124+
1125+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1126+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1127+
1128+--TODO: Avoid the duplication between this and R.zipDynWith
1129+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1130+zipDynWith f da db =
1131+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
1132+ ec = flip push eab $ \o -> do
1133+ (a, b) <- case o of
1134+ This (Identity a) -> do
1135+ b <- readBehaviorUntracked $ dynamicCurrent db
1136+ return (a, b)
1137+ That (Identity b) -> do
1138+ a <- readBehaviorUntracked $ dynamicCurrent da
1139+ return (a, b)
1140+ These (Identity a) (Identity b) -> return (a, b)
1141+ return $ Just $ Identity $ f a b
1142+ in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1143+
1144+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1145+buildDynamic readV0 v' = do
1146+ result <- liftIO $ newIORef $ Left (readV0, v')
1147+ let !d = Dyn result
1148+ defer $ SomeDynInit d
1149+ return d
1150+
1151+unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1152+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1153+ where x = (readV0, v')
1154+
1155+-- ResultM can read behaviors and events
1156+type ResultM = EventM
1157+
1158+{-# NOINLINE unsafeNewIORef #-}
1159+unsafeNewIORef :: a -> b -> IORef b
1160+unsafeNewIORef _ b = unsafePerformIO $ newIORef b
1161+
1162+instance HasSpiderTimeline x => Functor (Event x) where
1163+ fmap f = push $ return . Just . f
1164+
1165+instance Functor (Behavior x) where
1166+ fmap f = pull . fmap f . readBehaviorTracked
1167+
1168+{-# INLINE push #-}
1169+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1170+push f e = cacheEvent (pushCheap f e)
1171+
1172+{-# INLINABLE pull #-}
1173+pull :: BehaviorM x a -> Behavior x a
1174+pull a = behaviorPull $ Pull
1175+ { pullCompute = a
1176+ , pullValue = unsafeNewIORef a Nothing
1177+#ifdef DEBUG_NODEIDS
1178+ , pullNodeId = unsafeNodeId a
1179+#endif
1180+ }
1181+
1182+{-# INLINABLE switch #-}
1183+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1184+switch a = eventSwitch $ Switch
1185+ { switchParent = a
1186+ , switchSubscribed = unsafeNewIORef a Nothing
1187+ }
1188+
1189+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1190+coincidence a = eventCoincidence $ Coincidence
1191+ { coincidenceParent = a
1192+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1193+ }
1194+
1195+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1196+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1197+run roots after = do
1198+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1199+ t <- SpiderHost ask
1200+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1201+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1202+ occBefore <- liftIO $ do
1203+ occBefore <- readIORef occRef
1204+ writeIORef occRef $! DMap.insert k a occBefore
1205+ return occBefore
1206+ if DMap.null occBefore
1207+ then do scheduleRootClear occRef
1208+ return $ Just r
1209+ else return Nothing
1210+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1211+ propagate a subscribersRef
1212+ delayedRef <- asksEventEnv eventEnvDelayedMerges
1213+ let go = do
1214+ delayed <- liftIO $ readIORef delayedRef
1215+ case IntMap.minViewWithKey delayed of
1216+ Nothing -> return ()
1217+ Just ((currentHeight, cur), future) -> do
1218+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1219+ putCurrentHeight $ Height currentHeight
1220+ liftIO $ writeIORef delayedRef $! future
1221+ sequence_ cur
1222+ go
1223+ go
1224+ putCurrentHeight maxBound
1225+ after
1226+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1227+ return result
1228+
1229+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1230+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1231+ height <- liftIO $ readIORef heightRef
1232+ currentHeight <- getCurrentHeight
1233+ case height `compare` currentHeight of
1234+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1235+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1236+ EQ -> a
1237+
1238+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1239+
1240+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1241+
1242+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1243+
1244+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1245+
1246+debugFinalize :: Bool
1247+debugFinalize = False
1248+
1249+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1250+mkWeakPtrWithDebug x debugNote = do
1251+ x' <- evaluate x
1252+ mkWeakPtr x' $
1253+ if debugFinalize
1254+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1255+ else Nothing
1256+
1257+type WeakList a = [Weak a]
1258+
1259+{-# INLINE withIncreasedDepth #-}
1260+#ifdef DEBUG
1261+withIncreasedDepth :: CanTrace x m => m a -> m a
1262+withIncreasedDepth a = do
1263+ spiderTimeline <- askSpiderTimelineEnv
1264+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1265+ result <- a
1266+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1267+ return result
1268+#else
1269+withIncreasedDepth :: m a -> m a
1270+withIncreasedDepth = id
1271+#endif
1272+
1273+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1274+
1275+{-# INLINE tracePropagate #-}
1276+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1277+tracePropagate p = traceWhen p debugPropagate
1278+
1279+{-# INLINE traceInvalidate #-}
1280+traceInvalidate :: String -> IO ()
1281+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1282+
1283+{-# INLINE traceWhen #-}
1284+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1285+traceWhen p b message = traceMWhen p b $ return message
1286+
1287+{-# INLINE traceMWhen #-}
1288+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1289+traceMWhen _ b getMessage = when b $ do
1290+ message <- getMessage
1291+#ifdef DEBUG
1292+ spiderTimeline <- askSpiderTimelineEnv
1293+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1294+#else
1295+ let d = 0
1296+#endif
1297+ liftIO $ putStrLn $ replicate d ' ' <> message
1298+
1299+whoCreatedIORef :: IORef a -> IO [String]
1300+whoCreatedIORef (IORef a) = whoCreated $! a
1301+
1302+#ifdef DEBUG_CYCLES
1303+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1304+groupByHead = \case
1305+ [] -> []
1306+ (x :| xs) : t -> case groupByHead t of
1307+ [] -> [(x, xs :| [])]
1308+ l@((y, yss) : t')
1309+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1310+ | otherwise -> (x, xs :| []) : l
1311+
1312+listsToForest :: Eq a => [[a]] -> Forest a
1313+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1314+#endif
1315+
1316+{-# INLINE propagateSubscriberHold #-}
1317+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1318+propagateSubscriberHold h a = do
1319+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1320+ invalidators <- liftIO $ readIORef $ holdInvalidators h
1321+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1322+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1323+ case {-# SCC "apply" #-} apply a v of
1324+ Nothing -> return ()
1325+ Just v' -> do
1326+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1327+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1328+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1329+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1330+
1331+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1332+
1333+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1334+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1335+
1336+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1337+askInvalidator = do
1338+ (!m, _) <- BehaviorM ask
1339+ case m of
1340+ Nothing -> return Nothing
1341+ Just (!wi, _) -> return $ Just wi
1342+
1343+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1344+askParentsRef = do
1345+ (!m, _) <- BehaviorM ask
1346+ case m of
1347+ Nothing -> return Nothing
1348+ Just (_, !p) -> return $ Just p
1349+
1350+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1351+askBehaviorHoldInits = do
1352+ (_, !his) <- BehaviorM ask
1353+ return his
1354+
1355+{-# INLINE getDynHold #-}
1356+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1357+getDynHold d = do
1358+ mh <- liftIO $ readIORef $ unDyn d
1359+ case mh of
1360+ Right h -> return h
1361+ Left (readV0, v') -> do
1362+ holdInits <- getDeferralQueue
1363+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1364+ h <- hold v0 v'
1365+ liftIO $ writeIORef (unDyn d) $ Right h
1366+ return h
1367+
1368+-- Always refers to 0
1369+{-# NOINLINE zeroRef #-}
1370+zeroRef :: IORef Height
1371+zeroRef = unsafePerformIO $ newIORef zeroHeight
1372+
1373+type CanSubscribe x m =
1374+ ( HasSpiderTimeline x
1375+ , HasCurrentHeight x m
1376+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
1377+ , Defer SomeClear m -- Wiping out event firings
1378+ , Defer SomeIntClear m
1379+ , Defer (SomeAssignment x) m -- Updating state
1380+ , Defer (SomeResetCoincidence x) m
1381+ , m ~ EventM x
1382+ )
1383+
1384+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1385+getRootSubscribed k r sub = do
1386+ mSubscribed <- readIORef $ rootSubscribed r
1387+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1388+ case DMap.lookup k mSubscribed of
1389+ Just subscribed -> {-# SCC "hitRoot" #-} do
1390+ sln <- subscribeRootSubscribed subscribed sub
1391+ occ <- getOcc
1392+ return (sln, subscribed, occ)
1393+ Nothing -> {-# SCC "missRoot" #-} do
1394+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1395+ let !cached = rootSubscribed r
1396+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1397+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1398+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1399+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1400+ writeIORef uninitRef $! uninit
1401+ let !subscribed = RootSubscribed
1402+ { rootSubscribedKey = k
1403+ , rootSubscribedCachedSubscribed = cached
1404+ , rootSubscribedOccurrence = getOcc
1405+ , rootSubscribedSubscribers = subs
1406+ , rootSubscribedUninit = uninit
1407+ , rootSubscribedWeakSelf = weakSelf
1408+#ifdef DEBUG_NODEIDS
1409+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1410+#endif
1411+ }
1412+ -- If we die at the same moment that all our children die, they will
1413+ -- try to clean us up but will fail because their Weak reference to us
1414+ -- will also be dead. So, if we are dying, check if there are any
1415+ -- children; since children don't bother cleaning themselves up if
1416+ -- their parents are already dead, I don't think there's a race
1417+ -- condition here. However, if there are any children, then we can
1418+ -- infer that we need to clean ourselves up, so we do.
1419+ finalCleanup = do
1420+ cs <- readIORef $ _weakBag_children subs
1421+ when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1422+ writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1423+ 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
1424+ occ <- getOcc
1425+ return (sln, subscribed, occ)
1426+
1427+#ifdef USE_TEMPLATE_HASKELL
1428+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1429+#endif
1430+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1431+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1432+ rootSubscribedUninit self
1433+ modifyIORef' cached $ DMap.delete k
1434+
1435+{-# INLINE subscribeRootSubscribed #-}
1436+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1437+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1438+
1439+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1440+
1441+data FanInt x a = FanInt
1442+ { _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
1443+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1444+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1445+ }
1446+
1447+newFanInt :: IO (FanInt x a)
1448+newFanInt = do
1449+ 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
1450+ subscriptionRef <- newIORef $ error "fanInt: no subscription"
1451+ occRef <- newIORef $ error "fanInt: no occurrence"
1452+ return $ FanInt
1453+ { _fanInt_subscribers = subscribers
1454+ , _fanInt_subscriptionRef = subscriptionRef
1455+ , _fanInt_occRef = occRef
1456+ }
1457+
1458+{-# NOINLINE unsafeNewFanInt #-}
1459+unsafeNewFanInt :: b -> FanInt x a
1460+unsafeNewFanInt _ = unsafePerformIO newFanInt
1461+
1462+{-# NOINLINE fanInt #-}
1463+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1464+fanInt p =
1465+ let self = unsafeNewFanInt p
1466+ in EventSelectorInt $ \k -> Event $ \sub -> do
1467+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1468+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1469+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1470+ { subscriberPropagate = \m -> do
1471+ liftIO $ writeIORef (_fanInt_occRef self) m
1472+ scheduleIntClear $ _fanInt_occRef self
1473+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do
1474+ FastWeakBag.traverse b $ \s -> do
1475+ subscriberPropagate s v
1476+ , subscriberInvalidateHeight = \old -> do
1477+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1478+ FastWeakBag.traverse b $ \s -> do
1479+ subscriberInvalidateHeight s old
1480+ , subscriberRecalculateHeight = \new -> do
1481+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1482+ FastWeakBag.traverse b $ \s -> do
1483+ subscriberRecalculateHeight s new
1484+ }
1485+ liftIO $ do
1486+ writeIORef (_fanInt_subscriptionRef self) subscription
1487+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1488+ scheduleIntClear $ _fanInt_occRef self
1489+ liftIO $ do
1490+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1491+ Nothing -> do
1492+ b <- FastWeakBag.empty
1493+ FastMutableIntMap.insert (_fanInt_subscribers self) k b
1494+ return b
1495+ Just b -> return b
1496+ t <- liftIO $ FastWeakBag.insert sub b
1497+ currentOcc <- readIORef (_fanInt_occRef self)
1498+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1499+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny $! _fanInt_subscriptionRef self, IntMap.lookup k currentOcc)
1500+
1501+{-# INLINABLE getFanSubscribed #-}
1502+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)
1503+getFanSubscribed k f sub = do
1504+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1505+ case mSubscribed of
1506+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1507+ sln <- subscribeFanSubscribed k subscribed sub
1508+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1509+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1510+ Nothing -> {-# SCC "missFan" #-} do
1511+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1512+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1513+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1514+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1515+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1516+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1517+ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1518+ occRef <- liftIO $ newIORef parentOcc
1519+ when (isJust parentOcc) $ scheduleClear occRef
1520+ let subscribed = FanSubscribed
1521+ { fanSubscribedCachedSubscribed = fanSubscribed f
1522+ , fanSubscribedOccurrence = occRef
1523+ , fanSubscribedParent = subscription
1524+ , fanSubscribedSubscribers = subscribersRef
1525+#ifdef DEBUG_NODEIDS
1526+ , fanSubscribedNodeId = unsafeNodeId f
1527+#endif
1528+ }
1529+ let !self = (k, subscribed)
1530+ liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1531+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1532+ liftIO $ writeIORef subscribedRef $! subscribed
1533+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1534+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1535+
1536+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1537+cleanupFanSubscribed (k, subscribed) = do
1538+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1539+ let reducedSubscribers = DMap.delete k subscribers
1540+ if DMap.null reducedSubscribers
1541+ then do
1542+ unsubscribe $ fanSubscribedParent subscribed
1543+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1544+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1545+ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1546+
1547+{-# INLINE subscribeFanSubscribed #-}
1548+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1549+subscribeFanSubscribed k subscribed sub = do
1550+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1551+ case DMap.lookup k subscribers of
1552+ Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1553+ let !self = (k, subscribed)
1554+ weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1555+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1556+ 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
1557+ return sln
1558+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1559+
1560+{-# INLINABLE getSwitchSubscribed #-}
1561+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1562+getSwitchSubscribed s sub = do
1563+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1564+ case mSubscribed of
1565+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1566+ sln <- subscribeSwitchSubscribed subscribed sub
1567+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1568+ return (sln, subscribed, occ)
1569+ Nothing -> {-# SCC "missSwitch" #-} do
1570+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1571+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1572+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1573+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1574+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1575+ wiRef <- liftIO $ newIORef wi
1576+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1577+ holdInits <- getDeferralQueue
1578+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1579+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1580+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1581+ subscriptionRef <- liftIO $ newIORef subscription
1582+ occRef <- liftIO $ newIORef parentOcc
1583+ when (isJust parentOcc) $ scheduleClear occRef
1584+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1585+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1586+ let !subscribed = SwitchSubscribed
1587+ { switchSubscribedCachedSubscribed = switchSubscribed s
1588+ , switchSubscribedOccurrence = occRef
1589+ , switchSubscribedHeight = heightRef
1590+ , switchSubscribedSubscribers = subs
1591+ , switchSubscribedOwnInvalidator = i
1592+ , switchSubscribedOwnWeakInvalidator = wiRef
1593+ , switchSubscribedBehaviorParents = parentsRef
1594+ , switchSubscribedParent = switchParent s
1595+ , switchSubscribedCurrentParent = subscriptionRef
1596+ , switchSubscribedWeakSelf = weakSelf
1597+#ifdef DEBUG_NODEIDS
1598+ , switchSubscribedNodeId = unsafeNodeId s
1599+#endif
1600+ }
1601+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1602+ liftIO $ writeIORef subscribedRef $! subscribed
1603+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1604+ return (slnForSub, subscribed, parentOcc)
1605+
1606+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1607+cleanupSwitchSubscribed subscribed = do
1608+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1609+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1610+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1611+
1612+{-# INLINE subscribeSwitchSubscribed #-}
1613+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1614+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1615+
1616+{-# INLINABLE getCoincidenceSubscribed #-}
1617+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1618+getCoincidenceSubscribed c sub = do
1619+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1620+ case mSubscribed of
1621+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1622+ sln <- subscribeCoincidenceSubscribed subscribed sub
1623+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1624+ return (sln, subscribed, occ)
1625+ Nothing -> {-# SCC "missCoincidence" #-} do
1626+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1627+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1628+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1629+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1630+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1631+ (occ, height, mInnerSubd) <- case outerOcc of
1632+ Nothing -> return (Nothing, outerHeight, Nothing)
1633+ Just o -> do
1634+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1635+ return (occ, height, Just innerSubd)
1636+ occRef <- liftIO $ newIORef occ
1637+ when (isJust occ) $ scheduleClear occRef
1638+ heightRef <- liftIO $ newIORef height
1639+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1640+ scheduleClear innerSubdRef
1641+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1642+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1643+ let subscribed = CoincidenceSubscribed
1644+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1645+ , coincidenceSubscribedOccurrence = occRef
1646+ , coincidenceSubscribedHeight = heightRef
1647+ , coincidenceSubscribedSubscribers = subs
1648+ , coincidenceSubscribedOuter = subOuter
1649+ , coincidenceSubscribedOuterParent = outerSubscription
1650+ , coincidenceSubscribedInnerParent = innerSubdRef
1651+ , coincidenceSubscribedWeakSelf = weakSelf
1652+#ifdef DEBUG_NODEIDS
1653+ , coincidenceSubscribedNodeId = unsafeNodeId c
1654+#endif
1655+ }
1656+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1657+ liftIO $ writeIORef subscribedRef $! subscribed
1658+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1659+ return (slnForSub, subscribed, occ)
1660+
1661+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1662+cleanupCoincidenceSubscribed subscribed = do
1663+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1664+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1665+
1666+{-# INLINE subscribeCoincidenceSubscribed #-}
1667+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1668+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1669+
1670+{-# INLINE merge #-}
1671+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1672+merge d = cacheEvent (mergeCheap d)
1673+
1674+{-# INLINE mergeWithMove #-}
1675+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1676+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1677+
1678+{-# INLINE [1] mergeCheap #-}
1679+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1680+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1681+ where
1682+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1683+ updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1684+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1685+ (mOldSubd, newPs) <- case me of
1686+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1687+ Just e -> do
1688+ let s = subscriber $ return k
1689+ subscription@(EventSubscription _ subd) <- subscribe e s
1690+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1691+ let newParent = MergeSubscribedParent subscription
1692+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1693+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1694+ forM_ mOldSubd $ \oldSubd -> do
1695+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1696+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1697+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1698+ foldM f ([], oldParents) $ DMap.toList p
1699+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1700+ getInitialSubscribers initialParents subscriber = do
1701+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1702+ let s = subscriber $ return k
1703+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1704+ height <- liftIO $ getEventSubscribedHeight parentSubd
1705+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1706+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1707+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1708+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1709+ )
1710+ destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1711+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1712+
1713+{-# INLINE [1] mergeCheapWithMove #-}
1714+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1715+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1716+ where
1717+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1718+ updateMe subscriber heightBagRef oldParents p = do
1719+ -- Prepare new parents for insertion
1720+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1721+ subscribeParent k e = do
1722+ keyRef <- liftIO $ newIORef k
1723+ let s = subscriber $ liftIO $ readIORef keyRef
1724+ subscription@(EventSubscription _ subd) <- subscribe e s
1725+ liftIO $ do
1726+ newParentHeight <- getEventSubscribedHeight subd
1727+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1728+ return $ MergeSubscribedParentWithMove subscription keyRef
1729+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1730+ -- Collect old parents for deletion and update the keys of moved parents
1731+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1732+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1733+ Nothing -> do
1734+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1735+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1736+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1737+ Just toKey -> do
1738+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1739+ return Nothing
1740+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1741+ return (toDelete, applyAlways p' oldParents)
1742+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1743+ getInitialSubscribers initialParents subscriber = do
1744+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1745+ keyRef <- liftIO $ newIORef k
1746+ let s = subscriber $ liftIO $ readIORef keyRef
1747+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1748+ height <- liftIO $ getEventSubscribedHeight parentSubd
1749+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1750+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1751+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1752+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1753+ )
1754+ destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1755+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1756+
1757+type MergeUpdateFunc k x p s
1758+ = (forall a. EventM x (k a) -> Subscriber x a)
1759+ -> IORef HeightBag
1760+ -> DMap k s
1761+ -> p
1762+ -> EventM x ([EventSubscription x], DMap k s)
1763+
1764+type MergeInitFunc k x s
1765+ = DMap k (Event x)
1766+ -> (forall a. EventM x (k a) -> Subscriber x a)
1767+ -> EventM x (DMap k Identity, [Height], DMap k s)
1768+
1769+type MergeDestroyFunc k s
1770+ = DMap k s
1771+ -> IO ()
1772+
1773+data Merge x k s = Merge
1774+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1775+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1776+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1777+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1778+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1779+ }
1780+
1781+invalidateMergeHeight :: Merge x k s -> IO ()
1782+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1783+
1784+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1785+invalidateMergeHeight' heightRef sub = do
1786+ oldHeight <- readIORef heightRef
1787+ 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
1788+ writeIORef heightRef $! invalidHeight
1789+ subscriberInvalidateHeight sub oldHeight
1790+
1791+
1792+revalidateMergeHeight :: Merge x k s -> IO ()
1793+revalidateMergeHeight m = do
1794+ currentHeight <- readIORef $ _merge_heightRef m
1795+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1796+ heights <- readIORef $ _merge_heightBagRef m
1797+ parents <- readIORef $ _merge_parentsRef m
1798+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1799+ case heightBagSize heights `compare` DMap.size parents of
1800+ LT -> return ()
1801+ EQ -> do
1802+ let height = succHeight $ heightBagMax heights
1803+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1804+ writeIORef (_merge_heightRef m) $! height
1805+ subscriberRecalculateHeight (_merge_sub m) height
1806+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1807+
1808+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1809+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1810+ vals <- liftIO $ readIORef $ _merge_accumRef m
1811+ 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
1812+ --TODO: Assert that m is not empty
1813+ subscriberPropagate (_merge_sub m) vals
1814+
1815+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1816+mergeSubscriber m getKey = Subscriber
1817+ { subscriberPropagate = \a -> do
1818+ oldM <- liftIO $ readIORef $ _merge_accumRef m
1819+ k <- getKey
1820+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1821+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1822+ liftIO $ writeIORef (_merge_accumRef m) $! newM
1823+ when (DMap.null oldM) $ do -- Only schedule the firing once
1824+ height <- liftIO $ readIORef $ _merge_heightRef m
1825+ --TODO: assertions about height
1826+ currentHeight <- getCurrentHeight
1827+ when (height <= currentHeight) $ do
1828+ if height /= invalidHeight
1829+ then do
1830+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1831+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1832+ else liftIO $ do
1833+#ifdef DEBUG_CYCLES
1834+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1835+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1836+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1837+#else
1838+ let cycleInfo = ""
1839+#endif
1840+ error $ "Causality loop found" <> cycleInfo
1841+ scheduleMergeSelf m height
1842+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1843+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1844+ invalidateMergeHeight m
1845+ , subscriberRecalculateHeight = \new -> do
1846+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1847+ revalidateMergeHeight m
1848+ }
1849+
1850+--TODO: Be able to run as much of this as possible promptly
1851+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1852+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1853+ where updateMe = do
1854+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1855+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1856+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1857+ return subscriptionsToKill
1858+
1859+{-# INLINE mergeCheap' #-}
1860+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)
1861+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1862+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1863+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1864+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1865+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1866+ parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1867+ let m = Merge
1868+ { _merge_parentsRef = parentsRef
1869+ , _merge_heightBagRef = heightBagRef
1870+ , _merge_heightRef = heightRef
1871+ , _merge_sub = sub
1872+ , _merge_accumRef = accumRef
1873+ }
1874+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1875+ let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1876+ myHeight = if invalidHeight `elem` heights
1877+ then invalidHeight
1878+ else succHeight $ heightBagMax myHeightBag
1879+ currentHeight <- getCurrentHeight
1880+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1881+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1882+ else (Nothing, dm)
1883+ unless (DMap.null accum) $ do
1884+ scheduleMergeSelf m myHeight
1885+ liftIO $ writeIORef accumRef $! accum
1886+ liftIO $ writeIORef heightRef $! myHeight
1887+ liftIO $ writeIORef heightBagRef $! myHeightBag
1888+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1889+ liftIO $ writeIORef parentsRef $! initialParentState
1890+ defer $ SomeMergeInit $ do
1891+ let s = Subscriber
1892+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1893+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1894+ defer $ updateMerge m updateFunc a
1895+ , subscriberInvalidateHeight = \_ -> return ()
1896+ , subscriberRecalculateHeight = \_ -> return ()
1897+ }
1898+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1899+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
1900+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1901+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1902+ -- its subscription.
1903+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1904+ let unsubscribeAll = destroy =<< readIORef parentsRef
1905+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1906+ , occ
1907+ )
1908+
1909+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1910+mergeInt = cacheEvent . mergeIntCheap
1911+
1912+{-# INLINABLE mergeIntCheap #-}
1913+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1914+mergeIntCheap d = Event $ \sub -> do
1915+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1916+ accum <- liftIO $ FastMutableIntMap.newEmpty
1917+ heightRef <- liftIO $ newIORef zeroHeight
1918+ heightBagRef <- liftIO $ newIORef heightBagEmpty
1919+ parents <- liftIO $ FastMutableIntMap.newEmpty
1920+ let scheduleSelf = do
1921+ height <- liftIO $ readIORef $ heightRef
1922+ scheduleMerge' height heightRef $ do
1923+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
1924+ subscriberPropagate sub vals
1925+ invalidateMyHeight = do
1926+ invalidateMergeHeight' heightRef sub
1927+ recalculateMyHeight = do
1928+ currentHeight <- readIORef heightRef
1929+ 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?
1930+ heights <- readIORef heightBagRef
1931+ numParents <- FastMutableIntMap.size parents
1932+ case heightBagSize heights `compare` numParents of
1933+ LT -> return ()
1934+ EQ -> do
1935+ let height = succHeight $ heightBagMax heights
1936+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1937+ writeIORef heightRef $! height
1938+ subscriberRecalculateHeight sub height
1939+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1940+ mySubscriber k = Subscriber
1941+ { subscriberPropagate = \a -> do
1942+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1943+ liftIO $ FastMutableIntMap.insert accum k a
1944+ when wasEmpty scheduleSelf
1945+ , subscriberInvalidateHeight = \old -> do
1946+ modifyIORef' heightBagRef $ heightBagRemove old
1947+ invalidateMyHeight
1948+ , subscriberRecalculateHeight = \new -> do
1949+ modifyIORef' heightBagRef $ heightBagAdd new
1950+ recalculateMyHeight
1951+ }
1952+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do
1953+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
1954+ liftIO $ do
1955+ forM_ parentOcc $ FastMutableIntMap.insert accum k
1956+ FastMutableIntMap.insert parents k subscription
1957+ height <- getEventSubscribedHeight parentSubd
1958+ if height == invalidHeight
1959+ then writeIORef heightRef invalidHeight
1960+ else do
1961+ modifyIORef' heightBagRef $ heightBagAdd height
1962+ modifyIORef' heightRef $ \oldHeight ->
1963+ if oldHeight == invalidHeight
1964+ then invalidHeight
1965+ else max (succHeight height) oldHeight
1966+ myHeight <- liftIO $ readIORef heightRef
1967+ currentHeight <- getCurrentHeight
1968+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1969+ occ <- if currentHeight >= myHeight -- If we should have fired by now
1970+ then if isEmpty
1971+ then return Nothing
1972+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
1973+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
1974+ return Nothing
1975+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1976+ defer $ SomeMergeInit $ do
1977+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
1978+ where
1979+ u = do
1980+ let f k newParent = do
1981+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
1982+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1983+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1984+ return subscription
1985+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
1986+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
1987+ liftIO $ for_ oldParents $ \oldParent -> do
1988+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
1989+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
1990+ return $ IntMap.elems oldParents
1991+ let s = Subscriber
1992+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1993+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
1994+ defer $ updateMe a
1995+ , subscriberInvalidateHeight = \_ -> return ()
1996+ , subscriberRecalculateHeight = \_ -> return ()
1997+ }
1998+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1999+ forM_ change $ \c -> defer $ updateMe c
2000+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2001+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2002+ -- its subscription.
2003+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2004+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2005+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2006+ , occ
2007+ )
2008+
2009+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2010+
2011+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2012+fan e =
2013+ let f = Fan
2014+ { fanParent = e
2015+ , fanSubscribed = unsafeNewIORef e Nothing
2016+ }
2017+ in EventSelector $ \k -> eventFan k f
2018+
2019+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2020+runHoldInits holdInitRef dynInitRef mergeInitRef = do
2021+ holdInits <- liftIO $ readIORef holdInitRef
2022+ dynInits <- liftIO $ readIORef dynInitRef
2023+ mergeInits <- liftIO $ readIORef mergeInitRef
2024+ unless (null holdInits && null dynInits && null mergeInits) $ do
2025+ liftIO $ writeIORef holdInitRef []
2026+ liftIO $ writeIORef dynInitRef []
2027+ liftIO $ writeIORef mergeInitRef []
2028+ mapM_ initHold holdInits
2029+ mapM_ initDyn dynInits
2030+ mapM_ unSomeMergeInit mergeInits
2031+ runHoldInits holdInitRef dynInitRef mergeInitRef
2032+
2033+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2034+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2035+
2036+initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2037+initDyn (SomeDynInit d) = void $ getDynHold d
2038+
2039+newEventEnv :: IO (EventEnv x)
2040+newEventEnv = do
2041+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2042+ holdInitRef <- newIORef []
2043+ dynInitRef <- newIORef []
2044+ mergeUpdateRef <- newIORef []
2045+ mergeInitRef <- newIORef []
2046+ heightRef <- newIORef zeroHeight
2047+ toClearRef <- newIORef []
2048+ toClearIntRef <- newIORef []
2049+ toClearRootRef <- newIORef []
2050+ coincidenceInfosRef <- newIORef []
2051+ delayedRef <- newIORef IntMap.empty
2052+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2053+
2054+clearEventEnv :: EventEnv x -> IO ()
2055+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2056+ writeIORef toAssignRef []
2057+ writeIORef holdInitRef []
2058+ writeIORef dynInitRef []
2059+ writeIORef mergeUpdateRef []
2060+ writeIORef mergeInitRef []
2061+ writeIORef heightRef zeroHeight
2062+ writeIORef toClearRef []
2063+ writeIORef toClearIntRef []
2064+ writeIORef toClearRootRef []
2065+ writeIORef coincidenceInfosRef []
2066+ writeIORef delayedRef IntMap.empty
2067+
2068+-- | Run an event action outside of a frame
2069+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2070+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2071+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2072+ let go = do
2073+ result <- a
2074+ 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
2075+ return result
2076+ result <- runEventM go
2077+ toClear <- readIORef $ eventEnvClears env
2078+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2079+ toClearInt <- readIORef $ eventEnvIntClears env
2080+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2081+ toClearRoot <- readIORef $ eventEnvRootClears env
2082+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2083+ toAssign <- readIORef $ eventEnvAssignments env
2084+ toReconnectRef <- newIORef []
2085+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2086+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2087+ writeIORef vRef v
2088+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
2089+ writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2090+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2091+ writeIORef (eventEnvMergeUpdates env) []
2092+ when debugPropagate $ putStrLn "Updating merges"
2093+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2094+ when debugPropagate $ putStrLn "Updating merges done"
2095+ toReconnect <- readIORef toReconnectRef
2096+ clearEventEnv env
2097+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2098+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2099+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2100+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2101+ finalize wi
2102+ i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2103+ wi' <- mkWeakPtrWithDebug i "wi'"
2104+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2105+ writeIORef (switchSubscribedBehaviorParents subscribed) []
2106+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2107+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2108+ 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
2109+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2110+ sub <- newSubscriberSwitch subscribed
2111+ 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
2112+ {-
2113+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2114+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2115+ EventRoot _ -> "EventRoot"
2116+ EventNever -> "EventNever"
2117+ _ -> "something else"
2118+ -}
2119+ writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2120+ return oldSubscription
2121+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2122+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2123+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2124+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2125+ parentHeight <- getEventSubscribedHeight subd'
2126+ myHeight <- readIORef $ switchSubscribedHeight subscribed
2127+ when (parentHeight /= myHeight) $ do
2128+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2129+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2130+ 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
2131+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2132+ unsubscribe subscription
2133+ mapM_ invalidateCoincidenceHeight mcs
2134+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2135+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2136+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2137+ height <- calculateSwitchHeight subscribed
2138+ updateSwitchHeight height subscribed
2139+ return result
2140+
2141+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2142+
2143+{-# INLINE zeroHeight #-}
2144+zeroHeight :: Height
2145+zeroHeight = Height 0
2146+
2147+{-# INLINE invalidHeight #-}
2148+invalidHeight :: Height
2149+invalidHeight = Height (-1000)
2150+
2151+#ifdef DEBUG_CYCLES
2152+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2153+{-# INLINE invalidHeightBeingTraversed #-}
2154+invalidHeightBeingTraversed :: Height
2155+invalidHeightBeingTraversed = Height (-1001)
2156+#endif
2157+
2158+{-# INLINE succHeight #-}
2159+succHeight :: Height -> Height
2160+succHeight h@(Height a) =
2161+ if h == invalidHeight
2162+ then invalidHeight
2163+ else Height $ succ a
2164+
2165+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2166+invalidateCoincidenceHeight subscribed = do
2167+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2168+ when (oldHeight /= invalidHeight) $ do
2169+ writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2170+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2171+
2172+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2173+updateSwitchHeight new subscribed = do
2174+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
2175+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2176+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2177+ writeIORef (switchSubscribedHeight subscribed) $! new
2178+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2179+
2180+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2181+recalculateCoincidenceHeight subscribed = do
2182+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2183+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2184+ height <- calculateCoincidenceHeight subscribed
2185+ when (height /= invalidHeight) $ do
2186+ writeIORef (coincidenceSubscribedHeight subscribed) $! height
2187+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2188+
2189+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2190+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2191+
2192+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2193+calculateCoincidenceHeight subscribed = do
2194+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2195+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2196+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2197+
2198+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2199+
2200+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2201+invalidate toReconnectRef wis = do
2202+ forM_ wis $ \wi -> do
2203+ mi <- deRefWeak wi
2204+ case mi of
2205+ Nothing -> do
2206+ traceInvalidate "invalidate Dead"
2207+ return () --TODO: Should we clean this up here?
2208+ Just i -> do
2209+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2210+ case i of
2211+ InvalidatorPull p -> do
2212+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
2213+ mVal <- readIORef $ pullValue p
2214+ forM_ mVal $ \val -> do
2215+ writeIORef (pullValue p) Nothing
2216+ writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2217+ InvalidatorSwitch subscribed -> do
2218+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2219+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2220+ 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
2221+
2222+--------------------------------------------------------------------------------
2223+-- Reflex integration
2224+--------------------------------------------------------------------------------
2225+
2226+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2227+-- When we're specializing, we include this from Reflex.Class instead, because
2228+-- it needs access to these types; when we're not, we want them here, so our
2229+-- instance isn't an orphan instance.
2230+#include "SpiderTimeline.include.hs"
2231+#include "SpiderTimelineHost.include.hs"
2232+#endif
2233+
2234+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2235+unsafeNewSpiderTimelineEnv = do
2236+ lock <- newMVar ()
2237+ env <- newEventEnv
2238+#ifdef DEBUG
2239+ depthRef <- newIORef 0
2240+#endif
2241+ return $ SpiderTimelineEnv
2242+ { _spiderTimeline_lock = lock
2243+ , _spiderTimeline_eventEnv = env
2244+#ifdef DEBUG
2245+ , _spiderTimeline_depth = depthRef
2246+#endif
2247+ }
2248+
2249+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2250+-- | Create a new SpiderTimelineEnv
2251+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2252+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2253+
2254+data LocalSpiderTimeline x s
2255+
2256+instance Reifies s (SpiderTimelineEnv x) =>
2257+ HasSpiderTimeline (LocalSpiderTimeline x s) where
2258+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2259+
2260+localSpiderTimeline
2261+ :: Proxy s
2262+ -> SpiderTimelineEnv x
2263+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2264+localSpiderTimeline _ = unsafeCoerce
2265+
2266+-- | Pass a new timeline to the given function.
2267+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2268+withSpiderTimeline k = do
2269+ env <- unsafeNewSpiderTimelineEnv
2270+ reify env $ \s -> k $ localSpiderTimeline s env
2271+#endif
2272+
2273+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2274+
2275+type ComputeM = EventM
2276+
2277+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2278+
2279+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2280+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2281+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2282+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2283+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2284+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2285+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2286+ type PullM (SpiderTimeline x) = SpiderPullM x
2287+ type PushM (SpiderTimeline x) = SpiderPushM x
2288+ {-# INLINABLE never #-}
2289+ never = SpiderEvent eventNever
2290+ {-# INLINABLE constant #-}
2291+ constant = SpiderBehavior . behaviorConst
2292+ {-# INLINE push #-}
2293+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
2294+ {-# INLINE pushCheap #-}
2295+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2296+ {-# INLINABLE pull #-}
2297+ pull = SpiderBehavior . pull . coerce
2298+ {-# INLINABLE merge #-}
2299+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2300+ {-# INLINABLE fan #-}
2301+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2302+ {-# INLINABLE switch #-}
2303+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2304+ {-# INLINABLE coincidence #-}
2305+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2306+ {-# INLINABLE current #-}
2307+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2308+ {-# INLINABLE updated #-}
2309+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2310+ {-# INLINABLE unsafeBuildDynamic #-}
2311+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2312+ {-# INLINABLE unsafeBuildIncremental #-}
2313+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2314+ {-# INLINABLE mergeIncremental #-}
2315+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2316+ {-# INLINABLE mergeIncrementalWithMove #-}
2317+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2318+ {-# INLINABLE currentIncremental #-}
2319+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2320+ {-# INLINABLE updatedIncremental #-}
2321+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2322+ {-# INLINABLE incrementalToDynamic #-}
2323+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2324+ c <- readBehaviorUntracked $ dynamicCurrent i
2325+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2326+ eventCoercion Coercion = Coercion
2327+ behaviorCoercion Coercion = Coercion
2328+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2329+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2330+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2331+#endif
2332+
2333+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2334+
2335+data SpiderEventHandle x a = SpiderEventHandle
2336+ { spiderEventHandleSubscription :: EventSubscription x
2337+ , spiderEventHandleValue :: IORef (Maybe a)
2338+ }
2339+
2340+instance MonadRef (EventM x) where
2341+ type Ref (EventM x) = Ref IO
2342+ {-# INLINABLE newRef #-}
2343+ {-# INLINABLE readRef #-}
2344+ {-# INLINABLE writeRef #-}
2345+ newRef = liftIO . newRef
2346+ readRef = liftIO . readRef
2347+ writeRef r a = liftIO $ writeRef r a
2348+
2349+instance MonadAtomicRef (EventM x) where
2350+ {-# INLINABLE atomicModifyRef #-}
2351+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
2352+
2353+-- | The monad for actions that manipulate a Spider timeline identified by @x@
2354+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2355+
2356+instance Monad (SpiderHost x) where
2357+ {-# INLINABLE (>>=) #-}
2358+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2359+ {-# INLINABLE (>>) #-}
2360+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2361+ {-# INLINABLE return #-}
2362+ return x = SpiderHost $ return x
2363+ {-# INLINABLE fail #-}
2364+ fail s = SpiderHost $ fail s
2365+
2366+-- | Run an action affecting the global Spider timeline; this will be guarded by
2367+-- a mutex for that timeline
2368+runSpiderHost :: SpiderHost Global a -> IO a
2369+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2370+
2371+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2372+-- | Run an action affecting a given Spider timeline; this will be guarded by a
2373+-- mutex for that timeline
2374+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2375+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2376+#endif
2377+
2378+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2379+
2380+instance Monad (SpiderHostFrame x) where
2381+ {-# INLINABLE (>>=) #-}
2382+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2383+ {-# INLINABLE (>>) #-}
2384+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2385+ {-# INLINABLE return #-}
2386+ return x = SpiderHostFrame $ return x
2387+ {-# INLINABLE fail #-}
2388+ fail s = SpiderHostFrame $ fail s
2389+
2390+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2391+newEventWithTriggerIO f = do
2392+ es <- newFanEventWithTriggerIO $ \Refl -> f
2393+ return $ select es Refl
2394+
2395+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2396+newFanEventWithTriggerIO f = do
2397+ occRef <- newIORef DMap.empty
2398+ subscribedRef <- newIORef DMap.empty
2399+ let !r = Root
2400+ { rootOccurrence = occRef
2401+ , rootSubscribed = subscribedRef
2402+ , rootInit = f
2403+ }
2404+ return $ EventSelector $ \k -> eventRoot k r
2405+
2406+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2407+
2408+instance MonadRef (SpiderHost x) where
2409+ type Ref (SpiderHost x) = Ref IO
2410+ newRef = SpiderHost . newRef
2411+ readRef = SpiderHost . readRef
2412+ writeRef r = SpiderHost . writeRef r
2413+
2414+instance MonadAtomicRef (SpiderHost x) where
2415+ atomicModifyRef r = SpiderHost . atomicModifyRef r
2416+
2417+instance MonadRef (SpiderHostFrame x) where
2418+ type Ref (SpiderHostFrame x) = Ref IO
2419+ newRef = SpiderHostFrame . newRef
2420+ readRef = SpiderHostFrame . readRef
2421+ writeRef r = SpiderHostFrame . writeRef r
2422+
2423+instance MonadAtomicRef (SpiderHostFrame x) where
2424+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2425+
2426+instance PrimMonad (SpiderHostFrame x) where
2427+ type PrimState (SpiderHostFrame x) = PrimState IO
2428+ primitive = SpiderHostFrame . EventM . primitive
src/Reflex/Spider/SpiderTimeline.include.hsnew file+137
@@ -0,0 +1,137 @@
1+-- | Designates the default, global Spider timeline
2+data SpiderTimeline x
3+type role SpiderTimeline nominal
4+
5+-- | The default, global Spider environment
6+type Spider = SpiderTimeline Global
7+
8+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where
9+ {-# INLINABLE sample #-}
10+ sample (SpiderBehavior b) = readBehaviorUntracked b
11+
12+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where
13+ {-# INLINABLE hold #-}
14+ hold = holdSpiderEventM
15+ {-# INLINABLE holdDyn #-}
16+ holdDyn = holdDynSpiderEventM
17+ {-# INLINABLE holdIncremental #-}
18+ holdIncremental = holdIncrementalSpiderEventM
19+ {-# INLINABLE buildDynamic #-}
20+ buildDynamic = buildDynamicSpiderEventM
21+
22+instance (
23+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
24+ x ~ Global
25+#endif
26+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
27+ {-# INLINABLE sample #-}
28+ sample = coerce . readBehaviorTracked . unSpiderBehavior
29+
30+instance (
31+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
32+ x ~ Global
33+#else
34+ HasSpiderTimeline x
35+#endif
36+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
37+ {-# INLINABLE sample #-}
38+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
39+
40+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
41+ {-# INLINABLE hold #-}
42+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
43+ {-# INLINABLE holdDyn #-}
44+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
45+ {-# INLINABLE holdIncremental #-}
46+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
47+ {-# INLINABLE buildDynamic #-}
48+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
49+
50+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
51+ {-# INLINE return #-}
52+ return = pure
53+ {-# INLINE (>>=) #-}
54+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
55+ {-# INLINE (>>) #-}
56+ _ >> y = y
57+ {-# INLINE fail #-}
58+ fail _ = error "Dynamic does not support 'fail'"
59+
60+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
61+newJoinDyn d =
62+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
63+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
64+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
65+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
66+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
67+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
68+
69+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
70+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
71+
72+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
73+ pure = SpiderDynamic . dynamicConst
74+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
75+ _ *> b = b
76+ a <* _ = a
77+
78+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
79+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
80+
81+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
82+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
83+
84+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
85+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
86+
87+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
88+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
89+
90+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
91+ {-# INLINABLE hold #-}
92+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
93+ {-# INLINABLE holdDyn #-}
94+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
95+ {-# INLINABLE holdIncremental #-}
96+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
97+ {-# INLINABLE buildDynamic #-}
98+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
99+
100+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
101+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
102+
103+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
104+ {-# INLINABLE hold #-}
105+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
106+ {-# INLINABLE holdDyn #-}
107+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
108+ {-# INLINABLE holdIncremental #-}
109+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
110+ {-# INLINABLE buildDynamic #-}
111+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
112+
113+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
114+ {-# INLINABLE sample #-}
115+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
116+
117+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
118+ {-# INLINABLE sample #-}
119+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
120+
121+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
122+ {-# INLINABLE hold #-}
123+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
124+ {-# INLINABLE holdDyn #-}
125+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
126+ {-# INLINABLE holdIncremental #-}
127+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
128+ {-# INLINABLE buildDynamic #-}
129+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
130+
131+--------------------------------------------------------------------------------
132+-- Deprecated items
133+--------------------------------------------------------------------------------
134+
135+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
136+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
137+type SpiderEnv = SpiderTimeline
src/Reflex/Spider/SpiderTimelineHost.include.hsnew file+57
@@ -0,0 +1,57 @@
1+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2+ {-# INLINABLE subscribeEvent #-}
3+ subscribeEvent e = SpiderHostFrame $ do
4+ --TODO: Unsubscribe eventually (manually and/or with weak ref)
5+ val <- liftIO $ newIORef Nothing
6+ subscription <- subscribe (unSpiderEvent e) $ Subscriber
7+ { subscriberPropagate = \a -> do
8+ liftIO $ writeIORef val $ Just a
9+ scheduleClear val
10+ , subscriberInvalidateHeight = \_ -> return ()
11+ , subscriberRecalculateHeight = \_ -> return ()
12+ }
13+ return $ SpiderEventHandle
14+ { spiderEventHandleSubscription = subscription
15+ , spiderEventHandleValue = val
16+ }
17+
18+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
19+ type EventTrigger (SpiderTimeline x) = RootTrigger x
20+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x
21+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x
22+
23+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
24+ {-# NOINLINE readEvent #-}
25+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
26+ result <- readIORef $ spiderEventHandleValue h
27+ touch h
28+ return result
29+
30+instance (
31+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
32+ x ~ Global
33+#endif
34+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
35+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
36+ newFanEventWithTrigger f = SpiderHost $ lift $ do
37+ es <- newFanEventWithTriggerIO f
38+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
39+
40+instance (
41+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
42+ x ~ Global
43+#endif
44+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
45+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
46+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
47+ es <- newFanEventWithTriggerIO f
48+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
49+
50+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
51+ {-# INLINABLE subscribeEvent #-}
52+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
53+
54+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
55+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
56+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
57+ runHostFrame = runFrame . runSpiderHostFrame
src/Reflex/TriggerEvent/Base.hsnew file+131
@@ -0,0 +1,131 @@
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.Concurrent
17+import Control.Monad.Exception
18+import Control.Monad.Primitive
19+import Control.Monad.Reader
20+import Control.Monad.Ref
21+import Data.Coerce
22+import Data.Dependent.Sum
23+import Data.IORef
24+import Reflex.Class
25+import Reflex.Host.Class
26+import Reflex.PerformEvent.Class
27+import Reflex.PostBuild.Class
28+import Reflex.TriggerEvent.Class
29+
30+-- | A value with which to fire an 'Event', as well as a callback to invoke
31+-- after its propagation has completed.
32+data TriggerInvocation a = TriggerInvocation a (IO ())
33+
34+-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
35+newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }
36+
37+-- | A basic implementation of 'TriggerEvent'.
38+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }
39+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
40+
41+-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
42+-- 'TriggerInvocation's can be passed; it is expected that some other thread
43+-- will be responsible for popping values out of the 'Chan' and firing their
44+-- 'EventTrigger's.
45+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
46+runTriggerEventT = runReaderT . unTriggerEventT
47+
48+instance MonadTrans (TriggerEventT t) where
49+ {-# INLINABLE lift #-}
50+ lift = TriggerEventT . lift
51+
52+instance PrimMonad m => PrimMonad (TriggerEventT t m) where
53+ type PrimState (TriggerEventT t m) = PrimState m
54+ {-# INLINABLE primitive #-}
55+ primitive = lift . primitive
56+
57+instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
58+ type Performable (TriggerEventT t m) = Performable m
59+ {-# INLINABLE performEvent_ #-}
60+ performEvent_ e = lift $ performEvent_ e
61+ {-# INLINABLE performEvent #-}
62+ performEvent e = lift $ performEvent e
63+
64+instance PostBuild t m => PostBuild t (TriggerEventT t m) where
65+ {-# INLINABLE getPostBuild #-}
66+ getPostBuild = lift getPostBuild
67+
68+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
69+ {-# INLINABLE newEventWithTrigger #-}
70+ newEventWithTrigger = lift . newEventWithTrigger
71+ {-# INLINABLE newFanEventWithTrigger #-}
72+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
73+
74+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
75+ {-# INLINABLE newTriggerEvent #-}
76+ newTriggerEvent = do
77+ (e, t) <- newTriggerEventWithOnComplete
78+ return (e, \a -> t a $ return ())
79+ {-# INLINABLE newTriggerEventWithOnComplete #-}
80+ newTriggerEventWithOnComplete = do
81+ events <- askEvents
82+ (eResult, reResultTrigger) <- lift newEventWithTriggerRef
83+ return . (,) eResult $ \a cb ->
84+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
85+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
86+ newEventWithLazyTriggerWithOnComplete f = do
87+ events <- askEvents
88+ lift . newEventWithTrigger $ \t ->
89+ f $ \a cb -> do
90+ reResultTrigger <- newRef $ Just t
91+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
92+
93+instance MonadRef m => MonadRef (TriggerEventT t m) where
94+ type Ref (TriggerEventT t m) = Ref m
95+ {-# INLINABLE newRef #-}
96+ newRef = lift . newRef
97+ {-# INLINABLE readRef #-}
98+ readRef = lift . readRef
99+ {-# INLINABLE writeRef #-}
100+ writeRef r = lift . writeRef r
101+
102+instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
103+ {-# INLINABLE atomicModifyRef #-}
104+ atomicModifyRef r = lift . atomicModifyRef r
105+
106+instance MonadSample t m => MonadSample t (TriggerEventT t m) where
107+ {-# INLINABLE sample #-}
108+ sample = lift . sample
109+
110+instance MonadHold t m => MonadHold t (TriggerEventT t m) where
111+ {-# INLINABLE hold #-}
112+ hold v0 v' = lift $ hold v0 v'
113+ {-# INLINABLE holdDyn #-}
114+ holdDyn v0 v' = lift $ holdDyn v0 v'
115+ {-# INLINABLE holdIncremental #-}
116+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
117+
118+instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where
119+ {-# INLINABLE runWithReplace #-}
120+ runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')
121+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
122+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'
123+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
124+ traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'
125+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
126+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'
127+
128+-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
129+-- be fired.
130+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
131+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
stylizedeleted−4
@@ -1,4 +0,0 @@
1−#!/usr/bin/env bash
2−set -euo pipefail
3−
4−for x in **/*.hs ; do stylish-haskell -i "$x" ; done
test/EventWriterT.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE FlexibleContexts, GADTs #-}
2+module Main where
3+
4+import Control.Lens
5+import Control.Monad
6+import Data.These
7+
8+import Reflex
9+import Reflex.EventWriter
10+import Test.Run
11+
12+main :: IO ()
13+main = do
14+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
15+ [ Just ()
16+ ]
17+ print os1
18+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
19+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
20+ [ This ()
21+ , That ()
22+ , This ()
23+ , These () ()
24+ ]
25+ print os2
26+ return ()
27+
28+unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
29+unwrapApp x appIn = do
30+ ((), e) <- runEventWriterT $ x appIn
31+ return e
32+
33+testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
34+testOrdering pulse = do
35+ forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
36+ return ()
37+
38+testSimultaneous :: (Reflex t, MonadAdjust t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
39+testSimultaneous pulse = do
40+ let e0 = fmapMaybe (^? here) pulse
41+ e1 = fmapMaybe (^? there) pulse
42+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
43+ return ()
44+
test/GC.hsnew file+95
@@ -0,0 +1,95 @@
1+{-# LANGUAGE OverloadedStrings, FlexibleContexts, GADTs, TypeFamilies, RankNTypes, ScopedTypeVariables #-}
2+module Main where
3+
4+import Control.Monad
5+import Control.Monad.IO.Class
6+import Control.Monad.Ref
7+import Data.Align
8+import Data.Dependent.Map (DMap)
9+import qualified Data.Dependent.Map as DMap
10+import Data.Dependent.Sum
11+import Data.Functor.Identity
12+import Data.GADT.Compare
13+import Data.IORef
14+import Data.Semigroup
15+import Data.These
16+
17+import Data.Functor.Misc
18+import Reflex.Patch
19+
20+import qualified Reflex.Spider.Internal as S
21+import qualified Reflex.Host.Class as Host
22+
23+import System.Mem
24+import System.Exit
25+
26+main :: IO ()
27+main = do
28+ ref <- newIORef Nothing
29+ hostPerf ref
30+ readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)
31+
32+hostPerf :: IORef (Maybe Int) -> IO ()
33+hostPerf ref = S.runSpiderHost $ do
34+ ---- body
35+ liftIO $ putStrLn "#creating triggers"
36+ (response', responseTrigger) <- Host.newEventWithTriggerRef
37+ (eadd', addTriggerRef) <- Host.newEventWithTriggerRef
38+ let response = S.unSpiderEvent response'
39+ eadd = S.unSpiderEvent eadd'
40+ liftIO $ putStrLn "#creating event graph"
41+ eventToPerform <- Host.runHostFrame $ do
42+ (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
43+ <- S.SpiderHostFrame
44+ $ fmap ( S.merge
45+ . S.dynamicHold)
46+ $ S.hold DMap.empty
47+ -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
48+ $ (\e -> S.Event $ \sub -> do
49+ (s, o) <- S.subscribeAndRead e $ sub
50+ { S.subscriberPropagate = S.subscriberPropagate sub
51+ }
52+ return (s, o))
53+ $ runIdentity <$> S.select
54+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
55+ (WrapArg Request)
56+ return $ alignWith (mergeThese (<>))
57+ (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
58+ liftIO $ putStrLn "#eadd fired"
59+ return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just
60+ $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)
61+ (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)
62+ ---- epilogue
63+ eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)
64+ liftIO $ putStrLn "#performing GC" >> performMajorGC
65+ liftIO $ putStrLn "#attempting to fire eadd"
66+ mAddTrigger <- readRef addTriggerRef
67+ forM_ mAddTrigger $ \t -> replicateM_ 2 $ do
68+ liftIO $ putStrLn "#firing eadd"
69+ mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle
70+ case mToPerform of
71+ Nothing -> return ()
72+ Just toPerform -> do
73+ responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
74+ mrt <- readRef responseTrigger
75+ let followupEventTriggers = case mrt of
76+ Just rt -> [rt :=> Identity responses]
77+ Nothing -> []
78+ Host.fireEventsAndRead followupEventTriggers $ return ()
79+ return ()
80+ return ()
81+
82+data Tell a where
83+ Action :: Tell ()
84+ Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global))
85+
86+instance GEq Tell where
87+ geq Action Action = Just Refl
88+ geq Request Request = Just Refl
89+ geq _ _ = Nothing
90+
91+instance GCompare Tell where
92+ gcompare Action Action = GEQ
93+ gcompare Request Request = GEQ
94+ gcompare Action Request = GLT
95+ gcompare Request Action = GGT
test/QueryT.hsnew file+140
@@ -0,0 +1,140 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
8+
9+import Control.Lens
10+import Control.Monad.Fix
11+import Data.Align
12+import Data.AppendMap (AppendMap)
13+import qualified Data.AppendMap as AMap
14+import Data.Functor.Misc
15+import Data.Map (Map)
16+import qualified Data.Map as Map
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 :: AppendMap 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+ , MonadAdjust 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+ , MonadAdjust 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+ , MonadAdjust 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+listHoldWithKey :: forall t m k v a. (Ord k, MonadHold t m, MonadAdjust t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
128+listHoldWithKey m0 m' f = do
129+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
130+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
131+ (a0, a') <- sequenceDMapWithAdjust dm0 dm'
132+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
133+
134+
135+-- scam it out to test traverseDMapWithAdjustWithMove
136+listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, MonadAdjust t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
137+listHoldWithKeyWithMove m0 m' f = do
138+ (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
139+ incrementalToDynamic <$> holdIncremental n0 n'
140+-- -}
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+71
@@ -0,0 +1,71 @@
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+
44+instance MonadSample (Pure Int) PurePlan where
45+ sample = liftPlan . sample
46+
47+
48+instance TestPlan (Pure Int) PurePlan where
49+ plan occs = do
50+ PurePlan . modify $ IntSet.union (IntMap.keysSet m)
51+ return $ mapToPureEvent m
52+ where m = IntMap.fromList (first fromIntegral <$> occs)
53+
54+runPure :: PurePlan a -> (a, IntSet)
55+runPure (PurePlan p) = runStateT p mempty $ 0
56+
57+relavantTimes :: IntSet -> IntSet
58+relavantTimes occs = IntSet.fromList [0..l + 1]
59+ where l = fromMaybe 0 (fst <$> IntSet.maxView occs)
60+
61+testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a
62+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)
63+
64+testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)
65+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)
66+
67+
68+
69+
70+
71+
test/Reflex/Plan/Reflex.hsnew file+135
@@ -0,0 +1,135 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Reflex.Plan.Reflex
12+ ( TestPlan(..)
13+ , runPlan
14+ , Plan (..)
15+ , Schedule
16+ , Firing (..)
17+ , MonadIORef
18+
19+
20+ , readSchedule
21+ , readSchedule_
22+ , testSchedule
23+ , readEvent'
24+ , makeDense
25+
26+ , runTestE
27+ , runTestB
28+
29+ ) where
30+
31+import Reflex.Class
32+import Reflex.Host.Class
33+import Reflex.TestPlan
34+
35+import Control.Applicative
36+import Control.Monad
37+import Control.Monad.Identity
38+import Control.Monad.State.Strict
39+
40+import Control.Monad.Ref
41+import Data.Dependent.Sum (DSum (..))
42+import qualified Data.IntMap.Strict as IntMap
43+import Data.Maybe
44+import Data.Monoid
45+import Data.Traversable (sequenceA, traverse)
46+
47+import Control.DeepSeq
48+import Control.Exception
49+import Data.IntMap.Strict (IntMap)
50+import Data.IORef
51+import System.Mem
52+
53+-- Note: this import must come last to silence warnings from AMP
54+import Prelude
55+
56+type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)
57+
58+data Firing t where
59+ Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t
60+
61+
62+type Schedule t = IntMap [Firing t]
63+
64+-- Implementation of a TestPlan in terms of ReflexHost
65+newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)
66+
67+deriving instance ReflexHost t => Functor (Plan t)
68+deriving instance ReflexHost t => Applicative (Plan t)
69+deriving instance ReflexHost t => Monad (Plan t)
70+
71+deriving instance ReflexHost t => MonadSample t (Plan t)
72+deriving instance ReflexHost t => MonadHold t (Plan t)
73+deriving instance ReflexHost t => MonadFix (Plan t)
74+
75+
76+instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
77+ plan occurances = Plan $ do
78+ (e, ref) <- newEventWithTriggerRef
79+ modify (IntMap.unionWith mappend (firings ref))
80+ return e
81+
82+ where
83+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)
84+ makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
85+
86+
87+firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
88+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
89+
90+runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t)
91+runPlan (Plan p) = runHostFrame $ runStateT p mempty
92+
93+
94+makeDense :: Schedule t -> Schedule t
95+makeDense s = fromMaybe (emptyRange 0) $ do
96+ (end, _) <- fst <$> IntMap.maxViewWithKey s
97+ return $ IntMap.union s (emptyRange end)
98+ where
99+ emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))
100+
101+
102+-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
103+-- after the last event)
104+-- performGC is called at each frame to test for GC issues
105+testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
106+testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
107+
108+readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
109+readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
110+
111+readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m ()
112+readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule
113+
114+triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a
115+triggerFrame readResult _ occs = do
116+ triggers <- catMaybes <$> traverse firingTrigger occs
117+ liftIO . evaluate . force =<< fireEventsAndRead triggers readResult
118+
119+readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
120+readEvent' = readEvent >=> sequenceA
121+
122+
123+-- Convenience functions for running tests producing Events/Behaviors
124+runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a)
125+runTestB p = do
126+ (b, s) <- runPlan p
127+ testSchedule s $ sample b
128+
129+runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a))
130+runTestE p = do
131+ (e, s) <- runPlan p
132+ h <- subscribeEvent e
133+ testSchedule s (readEvent' h)
134+
135+
test/Reflex/Test.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+
8+module Reflex.Test
9+ ( testAgreement
10+ , compareResult
11+ , runTests
12+
13+ , module Reflex.TestPlan
14+
15+ ) where
16+
17+import Reflex.Spider
18+
19+import Reflex.TestPlan
20+
21+import Reflex.Plan.Pure
22+import Reflex.Plan.Reflex
23+
24+import Control.Monad
25+import Data.Monoid
26+
27+import Data.IntMap (IntMap)
28+
29+--import Data.Foldable
30+import System.Exit
31+
32+import Prelude
33+
34+
35+testAgreement :: TestCase -> IO Bool
36+testAgreement (TestE p) = do
37+ spider <- runSpiderHost $ runTestE p
38+ let results = [("spider", spider)]
39+
40+ compareResult results (testEvent $ runPure p)
41+
42+testAgreement (TestB p) = do
43+ spider <- runSpiderHost $ runTestB p
44+ let results = [("spider", spider)]
45+
46+ compareResult results (testBehavior $ runPure p)
47+
48+
49+compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool
50+compareResult results expected = fmap and $ forM results $ \(name, r) -> do
51+
52+ when (r /= expected) $ do
53+ putStrLn ("Got: " ++ show (name, r))
54+ putStrLn ("Expected: " ++ show expected)
55+ return (r == expected)
56+
57+
58+runTests :: [(String, TestCase)] -> IO ()
59+runTests testCases = do
60+ results <- forM testCases $ \(name, test) -> do
61+ putStrLn $ "Test: " <> name
62+ testAgreement test
63+ exitWith $ if and results
64+ then ExitSuccess
65+ else ExitFailure 1
66+
test/Reflex/Test/CrossImpl.hsnew file+258
@@ -0,0 +1,258 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecursiveDo #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+module Reflex.Test.CrossImpl (test) where
16+
17+import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)
18+
19+import Control.Monad.Ref
20+import Reflex.Class
21+import Reflex.Dynamic
22+import Reflex.Host.Class
23+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
24+import qualified Reflex.Pure as P
25+import qualified Reflex.Spider.Internal as S
26+
27+import Control.Arrow (second, (&&&))
28+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
30+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
31+import Data.Dependent.Map (DMap, DSum (..))
32+import qualified Data.Dependent.Map as DMap
33+import Data.Foldable
34+import Data.Functor.Misc
35+import Data.Map.Strict (Map)
36+import qualified Data.Map.Strict as Map
37+import qualified Data.Set as Set
38+import Data.Traversable
39+import System.Exit
40+import System.Mem
41+
42+import System.IO.Unsafe
43+
44+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
45+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
46+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
47+ Just (_, v) -> v
48+
49+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
50+mapToPureEvent m = P.Event $ flip Map.lookup m
51+
52+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
53+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
54+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
55+ _ -> [] -- Doesn't actually make much sense
56+
57+type PureReflexDomain = P.Pure Int
58+type TimeM = (->) Int
59+
60+testPure :: (t ~ PureReflexDomain, m ~ TimeM) => ((Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
61+testPure builder (b, e) =
62+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
63+ relevantTimes = relevantTestingTimes (b, e)
64+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
65+ b'' = Map.fromList $ map (id &&& b') relevantTimes
66+ in (b'', e'')
67+
68+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
69+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
70+
71+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
72+ mapMSignals fb _ = fb
73+
74+instance MapMSignals (Event t a) (Event t' a) t t' where
75+ mapMSignals _ fe = fe
76+
77+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
78+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
79+
80+testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
81+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
82+ (re, reTrigger) <- newEventWithTriggerRef
83+ (rb, rbTrigger) <- newEventWithTriggerRef
84+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
85+ (b', e') <- runHostFrame $ builder (b, re)
86+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
87+ let times = relevantTestingTimes (bMap, eMap)
88+ liftIO performGC
89+ outputs <- forM times $ \t -> do
90+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
91+ bOutput <- sample b'
92+ eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do
93+ mret <- readRef reTrigger
94+ let firing = case mret of
95+ Just ret -> [ret :=> Identity val]
96+ Nothing -> []
97+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
98+ liftIO performGC
99+ return (t, (bOutput, eOutput))
100+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
101+
102+tracePerf :: Show a => a -> b -> b
103+tracePerf = flip const
104+
105+testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> IO Bool
106+testAgreement builder inputs = do
107+ let identityResult = testPure builder inputs
108+ tracePerf "---------" $ return ()
109+ let spiderResult = testSpider builder inputs
110+ tracePerf "---------" $ return ()
111+ let resultsAgree = identityResult == spiderResult
112+ if resultsAgree
113+ then do --putStrLn "Success:"
114+ --print identityResult
115+ return ()
116+ else do putStrLn "Failure:"
117+ putStrLn $ "Pure result: " <> show identityResult
118+ putStrLn $ "Spider result: " <> show spiderResult
119+ return resultsAgree
120+
121+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
122+
123+data TestCase = forall a b c d. (Eq c, Eq d, Show c, Show d) => TestCase (Map Int a, Map Int b) (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
124+
125+testCases :: [(String, TestCase)]
126+testCases =
127+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
128+ b' <- hold "123" e
129+ return (b', e)
130+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
131+ e' <- updated <$> count e
132+ b' <- hold (0 :: Int) e'
133+ return (b', e')
134+ , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
135+ e' <- headE $ leftmost [e, e]
136+ return (b, e')
137+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
138+ let e' = fmap (const e) e
139+ b' <- hold never e'
140+ let e'' = switch b'
141+ return (b, e'')
142+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
143+ let e' = flip pushAlways e $ const $ do
144+ let eab = splitRecombineEvent e
145+ switch <$> hold eab never
146+ e'' = coincidence e'
147+ return (b, e'')
148+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
149+ let e' = flip pushAlways e $ const $ do
150+ let eab = splitRecombineEvent e
151+ switch <$> hold eab (fmap (const e) e)
152+ e'' = coincidence e'
153+ return (b, e'')
154+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
155+ let e' = leftmost [e, e]
156+ e'' <- switch <$> hold e' (fmap (const e) e)
157+ return (b, e'')
158+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
159+ let e' = fmap (const e) e
160+ e'' <- switchPromptly never e'
161+ return (b, e'')
162+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
163+ let e' = fmap (const e) e
164+ e'' <- switchPromptly never $ leftmost [e', e']
165+ return (b, e'')
166+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
167+ let e' = leftmost [e, e]
168+ e'' <- switchPromptly never (fmap (const e) e')
169+ return (b, e'')
170+ , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
171+ let e' = leftmost [e, e]
172+ e'' <- switchPromptly never (fmap (const e') e)
173+ return (b, e'')
174+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
175+ let e' = leftmost [e, e]
176+ e'' <- switch <$> hold never (fmap (const e') e)
177+ return (b, e'')
178+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
179+ let e' = flip push e $ \_ -> do
180+ Just <$> headE e
181+ e'' <- switchPromptly never e'
182+ return (b, e'')
183+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
184+ let e' = flip pushAlways e $ \_ -> do
185+ switchPromptly e never
186+ e'' <- switchPromptly never e'
187+ return (b, e'')
188+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
189+ let e' = flip pushAlways e $ \_ -> return e
190+ e'' = coincidence e'
191+ return (b, e'')
192+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
193+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
194+ e'' = coincidence e'
195+ return (b, e'')
196+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
197+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
198+ e'' = coincidence e'
199+ return (b, e'')
200+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
201+ let e' = flip pushAlways e $ \_ -> headE e
202+ e'' = coincidence e'
203+ return (b, e'')
204+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
205+ let eChild = flip pushAlways e $ const $ do
206+ let eNewValues = leftmost [e, e]
207+ return $ coincidence $ fmap (const eNewValues) eNewValues
208+ e' = coincidence eChild
209+ return (b, e')
210+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
211+ let eChild = flip pushAlways e $ const $ do
212+ let e' = coincidence $ fmap (const e) e
213+ return $ leftmost [e', e']
214+ e'' = coincidence eChild
215+ return (b, e'')
216+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
217+ let e' = leftmost [e, e]
218+ eCoincidences = coincidence $ fmap (const e') e
219+ return (b, eCoincidences)
220+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
221+ eo <- headE e
222+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
223+ let b' = pull $ sample =<< sample bb
224+ return (b', e)
225+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
226+ bb <- hold "b" e
227+ bd <- hold never . fmap (const e) =<< headE e
228+ eOuter <- pushAlways sample . fmap (const bb) <$> headE e
229+ let eInner = switch bd
230+ e' = leftmost [eOuter, eInner]
231+ return (b, e')
232+ , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do
233+ rec result <- holdUniqDyn d
234+ d <- holdDyn (0 :: Int) e
235+ return (current result, updated result)
236+ {-
237+ , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do
238+ x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e
239+ let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)
240+ return (b, e')
241+ -}
242+ ]
243+
244+splitRecombineEvent :: Reflex t => Event t a -> Event t String
245+splitRecombineEvent e =
246+ let ea = "a" <$ e
247+ eb = "b" <$ e
248+ in leftmost [ea, eb]
249+
250+
251+test :: IO ()
252+test = do
253+ results <- forM testCases $ \(name, TestCase inputs builder) -> do
254+ putStrLn $ "Test: " <> name
255+ testAgreement builder inputs
256+ exitWith $ if and results
257+ then ExitSuccess
258+ else ExitFailure 1
test/Reflex/Test/Micro.hsnew file+285
@@ -0,0 +1,285 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE RecursiveDo #-}
9+
10+module Reflex.Test.Micro (testCases) where
11+
12+import Reflex
13+import Reflex.TestPlan
14+
15+import Control.Applicative
16+import Control.Monad
17+import Control.Monad.Fix
18+import Data.Char
19+import Data.Foldable
20+import Data.Functor.Misc
21+import qualified Data.Map as Map
22+import Data.Monoid
23+
24+import Prelude
25+
26+{-# ANN testCases "HLint: ignore Functor law" #-}
27+testCases :: [(String, TestCase)]
28+testCases =
29+ [ testB "hold" $ hold "0" =<< events1
30+
31+ , testB "count" $ do
32+ b <- current <$> (count =<< events2)
33+ return $ (+ (0::Int)) <$> b
34+
35+ , testB "pull-1" $ do
36+ b <- hold "0" =<< events1
37+ return (pull $ sample $ pull $ sample b)
38+
39+ , testB "pull-2" $ do
40+ b1 <- behavior1
41+ return (pull $ liftA2 (<>) (sample b1) (sample b1))
42+
43+ , testB "pull-3" $ do
44+ b1 <- behavior1
45+ b2 <- behavior2
46+ return (pull $ liftA2 (<>) (sample b1) (sample b2))
47+
48+ , testB "pull-4" $ do
49+ es <- planList ["a", "b", "c"]
50+ e <- plan [(0, ())]
51+ b <- hold (constant "") $
52+ pushAlways (const $ hold "z" es) e
53+ return (join b)
54+
55+ , testE "id" $ do
56+ events2
57+
58+ , testE "fmap-id" $ do
59+ e <- events2
60+ return $ fmap id e
61+
62+ , testE "tag-1" $ do
63+ b1 <- behavior1
64+ e <- events2
65+ return (tag b1 e)
66+
67+ , testE "tag-2" $ do
68+ b1 <- behavior1
69+ e <- events2
70+ return (tag (map toUpper <$> b1) e)
71+
72+ , testE "attach-1" $ do
73+ b1 <- behavior1
74+ e <- events2
75+ return (attachWith (++) (map toUpper <$> b1) e)
76+
77+ , testE "leftmost" $ liftA2 leftmost2 events1 events2
78+
79+ , testE "appendEvents-1" $ liftA2 mappend events1 events2
80+
81+ , testE "appendEvents-2" $ liftA2 mappend events3 events2
82+
83+ , testE "merge-1" $ do
84+ e <- events1
85+ return $ leftmost ["x" <$ e, "y" <$ e]
86+
87+ , testE "merge-2" $ do
88+ e <- events1
89+ let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
90+ let ee = flip pushAlways e $ const $ return m
91+ return $ coincidence ee
92+
93+ , testE "headE-1" $ do
94+ e <- events1
95+ headE $ leftmost [e, e]
96+
97+ , testE "headE-2" $ do
98+ e <- events1
99+ b <- hold never (e <$ e)
100+ headE $ switch b
101+
102+ , testE "switch-1" $ do
103+ e <- events1
104+ b <- hold never (e <$ e)
105+ return $ switch b
106+
107+ , testE "switch-2" $ do
108+ e <- events1
109+ return $ coincidence $ flip pushAlways e $ const $ do
110+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)
111+
112+ , testE "switch-3" $ do
113+ e <- events1
114+ return $ coincidence $ flip pushAlways e $ const $ do
115+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never
116+
117+ , testE "switch-4" $ do
118+ e <- events1
119+ switch <$> hold (deep e) (e <$ e)
120+
121+ , testE "switch-5" $ do
122+ e <- events1
123+ return $ coincidence $ flip pushAlways e $ const $
124+ return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]
125+
126+ , testE "switch-6" $ do
127+ e <- events1
128+ return $ coincidence $ flip pushAlways e $ const $ do
129+ switch <$> hold ("x" <$ e) (e <$ e)
130+
131+ , testE "switchPromptly-1" $ do
132+ e <- events1
133+ let e' = e <$ e
134+ switchPromptly never $ e <$ e'
135+
136+ , testE "switchPromptly-2" $ do
137+ e <- events1
138+ switchPromptly never $ deep (e <$ e)
139+
140+ , testE "switchPromptly-3" $ do
141+ e <- events1
142+ switchPromptly never $ (e <$ deep e)
143+
144+ , testE "switchPromptly-4" $ do
145+ e <- events1
146+ switchPromptly never $ (deep e <$ e)
147+
148+ , testE "switch-5" $ do
149+ e <- events1
150+ switch <$> hold never (deep e <$ e)
151+
152+ , testE "switchPromptly-5" $ do
153+ e <- events1
154+ switchPromptly never $ flip push e $
155+ const (Just <$> headE e)
156+
157+ , testE "switchPromptly-6" $ do
158+ e <- events1
159+ switchPromptly never $ flip pushAlways e $
160+ const (switchPromptly 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+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-}
2+module Main where
3+
4+import Control.Lens
5+import Control.Monad
6+import qualified Data.Dependent.Map as DMap
7+import Data.Dependent.Sum
8+import Data.These
9+
10+import Reflex
11+import Reflex.Requester.Base
12+import Reflex.Requester.Class
13+import Test.Run
14+
15+data RequestInt a where
16+ RequestInt :: Int -> RequestInt Int
17+
18+main :: IO ()
19+main = do
20+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
21+ [ Just ()
22+ ]
23+ print os1
24+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
25+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
26+ [ This ()
27+ , That ()
28+ , This ()
29+ , These () ()
30+ ]
31+ print os2
32+ return ()
33+
34+unwrapRequest :: DSum tag RequestInt -> Int
35+unwrapRequest (_ :=> RequestInt i) = i
36+
37+unwrapApp :: ( Reflex t, Monad m )
38+ => (a -> RequesterT t RequestInt Identity m ())
39+ -> a
40+ -> m (Event t [Int])
41+unwrapApp x appIn = do
42+ ((), e) <- runRequesterT (x appIn) never
43+ return $ fmap (map unwrapRequest . DMap.toList) e
44+
45+testOrdering :: ( Response m ~ Identity
46+ , Request m ~ RequestInt
47+ , Requester t m
48+ , MonadAdjust t m)
49+ => Event t ()
50+ -> m ()
51+testOrdering pulse = do
52+ forM_ [10,9..1] $ \i -> requestingIdentity (RequestInt i <$ pulse)
53+ return ()
54+
55+testSimultaneous :: ( Response m ~ Identity
56+ , Request m ~ RequestInt
57+ , Requester t m
58+ , MonadAdjust t m)
59+ => Event t (These () ())
60+ -> m ()
61+testSimultaneous pulse = do
62+ let tellE = fmapMaybe (^? here) pulse
63+ switchE = fmapMaybe (^? there) pulse
64+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
65+ 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+10−6
@@ -1,11 +1,11 @@
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)
7−import System.FilePath
8import System.FilePath.Find
7import System.FilePath.Find
8+import System.FilePath
9
9
10main :: IO ()
10main :: IO ()
11main = do
11main = do
@@ -20,10 +20,7 @@ main = do
20 , "--ignore=Use >=>"
20 , "--ignore=Use >=>"
21 , "--ignore=Use ."
21 , "--ignore=Use ."
22 , "--ignore=Use unless"
22 , "--ignore=Use unless"
23− , "--ignore=Reduce duplication"
24 , "--cpp-define=USE_TEMPLATE_HASKELL"
23 , "--cpp-define=USE_TEMPLATE_HASKELL"
25− , "--ignore=Use tuple-section"
26− , "--ignore=Unused LANGUAGE pragma" -- hlint3 falsely believes that TypeOperators is not needed
27 ]
24 ]
28 recurseInto = and <$> sequence
25 recurseInto = and <$> sequence
29 [ fileType ==? Directory
26 [ fileType ==? Directory
@@ -31,9 +28,16 @@ main = do
31 ]
28 ]
32 matchFile = and <$> sequence
29 matchFile = and <$> sequence
33 [ extension ==? ".hs"
30 [ extension ==? ".hs"
31+ , let notElem' = liftOp notElem
32+ in filePath `notElem'` filePathExceptions pwd
34 ]
33 ]
35− files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.
34+ files <- find recurseInto matchFile pwd
36 ideas <- fmap concat $ forM files $ \f -> do
35 ideas <- fmap concat $ forM files $ \f -> do
37 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
36 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
38 runHlint f
37 runHlint f
39 if null ideas then exitSuccess else exitFailure
38 if null ideas then exitSuccess else exitFailure
39+
40+filePathExceptions :: FilePath -> [FilePath]
41+filePathExceptions pwd = map (pwd </>) $
42+ [ "src/Data/AppendMap.hs" -- parse error when hlint runs
43+ ]
test/rootCleanup.hsnew file+25
@@ -0,0 +1,25 @@
1+import Control.Monad
2+import Control.Concurrent
3+import Reflex
4+import Reflex.Host.Class
5+import System.Mem
6+import Data.IORef
7+import System.Exit
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