git.iko.soy/patch
on 6f255aa help sign in
b6af869
swap
0 ahead, 661 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+303
@@ -0,0 +1,303 @@
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+ syb >= 0.5 && < 0.8,
68+ these >= 0.4 && < 0.8,
69+ transformers >= 0.2,
70+ transformers-compat >= 0.3
71+
72+ exposed-modules:
73+ Data.AppendMap,
74+ Data.Functor.Misc,
75+ Data.WeakBag,
76+ Data.FastWeakBag,
77+ Data.FastMutableIntMap,
78+ Reflex,
79+ Reflex.Class,
80+ Reflex.EventWriter,
81+ Reflex.Dynamic,
82+ Reflex.Dynamic.Uniq,
83+ Reflex.DynamicWriter,
84+ Reflex.FastWeak,
85+ Reflex.FunctorMaybe,
86+ Reflex.Host.Class,
87+ Reflex.Patch,
88+ Reflex.Patch.Class,
89+ Reflex.Patch.DMap,
90+ Reflex.Patch.DMapWithMove,
91+ Reflex.Patch.Map,
92+ Reflex.Patch.MapWithMove,
93+ Reflex.TriggerEvent.Base,
94+ Reflex.TriggerEvent.Class,
95+ Reflex.PerformEvent.Base,
96+ Reflex.PerformEvent.Class,
97+ Reflex.PostBuild.Base,
98+ Reflex.PostBuild.Class,
99+ Reflex.Profiled,
100+ Reflex.Query.Base,
101+ Reflex.Query.Class,
102+ Reflex.Requester.Base,
103+ Reflex.Requester.Class,
104+ Reflex.Spider,
105+ Reflex.Spider.Internal,
106+ Reflex.Widget.Basic
107+
108+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
109+ ghc-prof-options: -fprof-auto
110+
111+ if flag(specialize-to-spidertimeline-global)
112+ cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
113+ else
114+ exposed-modules: Reflex.Pure
115+
116+ if flag(debug-trace-events)
117+ cpp-options: -DDEBUG_TRACE_EVENTS
118+ build-depends: bytestring
119+
120+ if flag(use-reflex-optimizer)
121+ cpp-options: -DUSE_REFLEX_OPTIMIZER
122+ build-depends: ghc
123+ exposed-modules: Reflex.Optimizer
124+
125+ if flag(use-template-haskell)
126+ cpp-options: -DUSE_TEMPLATE_HASKELL
127+ build-depends:
128+ dependent-sum >= 0.3 && < 0.5,
129+ haskell-src-exts >= 1.16 && < 1.19,
130+ haskell-src-meta >= 0.6 && < 0.9,
131+ template-haskell >= 2.9 && < 2.13
132+ exposed-modules:
133+ Reflex.Dynamic.TH
134+ other-extensions: TemplateHaskell
135+ else
136+ build-depends:
137+ dependent-sum == 0.4.*
138+
139+ if flag(expose-all-unfoldings)
140+ ghc-options: -fexpose-all-unfoldings
141+
142+ if flag(experimental-dependent-sum-instances)
143+ ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES
144+
145+ if impl(ghcjs)
146+ build-depends: ghcjs-base
147+
148+test-suite semantics
149+ type: exitcode-stdio-1.0
150+ main-is: semantics.hs
151+ hs-source-dirs: test
152+ ghc-options: -O2 -Wall -rtsopts
153+ build-depends:
154+ base,
155+ bifunctors,
156+ containers,
157+ deepseq >= 1.3 && < 1.5,
158+ dependent-map,
159+ dependent-sum,
160+ mtl,
161+ ref-tf,
162+ reflex,
163+ split,
164+ transformers >= 0.3
165+ if flag(specialize-to-spidertimeline-global)
166+ buildable: False
167+
168+test-suite CrossImpl
169+ type: exitcode-stdio-1.0
170+ main-is: Reflex/Test/CrossImpl.hs
171+ hs-source-dirs: test
172+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test
173+ build-depends:
174+ base,
175+ containers,
176+ dependent-map,
177+ mtl,
178+ ref-tf,
179+ reflex
180+ if flag(specialize-to-spidertimeline-global)
181+ buildable: False
182+
183+test-suite hlint
184+ type: exitcode-stdio-1.0
185+ main-is: hlint.hs
186+ hs-source-dirs: test
187+ build-depends: base
188+ , directory
189+ , filepath
190+ , filemanip
191+ , hlint == 1.9.*
192+ if impl(ghcjs)
193+ buildable: False
194+ buildable: False
195+
196+test-suite EventWriterT
197+ type: exitcode-stdio-1.0
198+ main-is: EventWriterT.hs
199+ hs-source-dirs: test
200+ build-depends: base
201+ , dependent-sum
202+ , lens
203+ , these
204+ , transformers
205+ , reflex
206+ , ref-tf
207+
208+test-suite RequesterT
209+ type: exitcode-stdio-1.0
210+ main-is: RequesterT.hs
211+ hs-source-dirs: test
212+ build-depends: base
213+ , dependent-sum
214+ , dependent-map
215+ , lens
216+ , these
217+ , transformers
218+ , reflex
219+ , ref-tf
220+ buildable: False
221+
222+test-suite QueryT
223+ type: exitcode-stdio-1.0
224+ main-is: QueryT.hs
225+ hs-source-dirs: test
226+ build-depends: base
227+ , containers
228+ , dependent-sum
229+ , dependent-map
230+ , lens
231+ , these
232+ , transformers
233+ , reflex
234+ , ref-tf
235+
236+test-suite GC-Semantics
237+ type: exitcode-stdio-1.0
238+ main-is: GC.hs
239+ hs-source-dirs: test
240+ if flag(specialize-to-spidertimeline-global)
241+ buildable: False
242+ build-depends: base
243+ , dependent-sum
244+ , dependent-map
245+ , these
246+ , transformers
247+ , reflex
248+ , ref-tf
249+ if impl(ghc < 8)
250+ build-depends: semigroups
251+
252+test-suite rootCleanup
253+ type: exitcode-stdio-1.0
254+ main-is: rootCleanup.hs
255+ hs-source-dirs: test
256+ build-depends: base
257+ , reflex
258+
259+benchmark spider-bench
260+ type: exitcode-stdio-1.0
261+ hs-source-dirs: bench
262+ main-is: Main.hs
263+ ghc-options: -Wall -O2 -rtsopts
264+ build-depends:
265+ base,
266+ criterion == 1.1.*,
267+ deepseq >= 1.3 && < 1.5,
268+ dependent-map,
269+ dependent-sum,
270+ mtl,
271+ primitive,
272+ reflex,
273+ stm,
274+ transformers >= 0.3
275+
276+benchmark saulzar-bench
277+ type: exitcode-stdio-1.0
278+ hs-source-dirs: bench test
279+ c-sources: bench-cbits/checkCapability.c
280+ main-is: RunAll.hs
281+ ghc-options: -Wall -O2 -rtsopts -threaded
282+ ghc-prof-options: -fprof-auto
283+ build-depends:
284+ base,
285+ containers == 0.5.*,
286+ criterion == 1.1.*,
287+ deepseq >= 1.3 && < 1.5,
288+ dependent-map,
289+ dependent-sum,
290+ loch-th,
291+ mtl,
292+ primitive,
293+ process,
294+ ref-tf,
295+ reflex,
296+ split,
297+ stm,
298+ time,
299+ transformers >= 0.3
300+
301+source-repository head
302+ type: git
303+ location: https://github.com/reflex-frp/reflex
release.nixdeleted−49
@@ -1,49 +0,0 @@
1−{ reflex-platform-fun ? import ./dep/reflex-platform
2−}:
3−
4−let
5− native-reflex-platform = reflex-platform-fun {};
6− inherit (native-reflex-platform.nixpkgs) lib;
7− systems = ["x86_64-linux" "x86_64-darwin"];
8−
9− perPlatform = lib.genAttrs systems (system: let
10− reflex-platform = reflex-platform-fun { inherit system; };
11− compilers = [
12− "ghc"
13− "ghcjs"
14− ] ++ lib.optionals (reflex-platform.androidSupport) [
15− "ghcAndroidAarch64"
16− "ghcAndroidAarch32"
17− ] ++ lib.optionals (reflex-platform.iosSupport) [
18− "ghcIosAarch64"
19− ];
20− compilerPkgs = lib.genAttrs compilers (ghc: let
21− reflex-platform = reflex-platform-fun {
22− inherit system;
23− haskellOverlays = [
24− # Use this package's source for reflex
25− (self: super: {
26− _dep = super._dep // {
27− patch = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
28− "release.nix"
29− ".git"
30− "dist"
31− "dist-newstyle"
32− "cabal.haskell-ci"
33− "cabal.project"
34− ".travis.yml"
35− ])) ./.;
36− };
37− })
38− ];
39− };
40− in reflex-platform.${ghc}.patch);
41− in compilerPkgs // {
42− cache = reflex-platform.pinBuildInputs "patch-${system}"
43− (builtins.attrValues compilerPkgs);
44− });
45−
46− metaCache = native-reflex-platform.pinBuildInputs "patch-everywhere"
47− (map (a: a.cache) (builtins.attrValues perPlatform));
48−
49−in perPlatform // { inherit metaCache; }
src/Data/AppendMap.hsnew file+408
@@ -0,0 +1,408 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RoleAnnotations #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+-- | 'Data.Map' with a better 'Monoid' instance
12+--
13+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has
14+-- @mappend = unionWith mappend@ instead.
15+module Data.AppendMap where
16+
17+import Prelude hiding (map)
18+
19+import Control.Lens
20+import Data.Align
21+import Data.Coerce
22+import Data.Default
23+import Data.Map (Map)
24+import qualified Data.Map as Map
25+import Data.Semigroup
26+import Data.Set (Set)
27+import Data.Typeable
28+import GHC.Generics (Generic)
29+import Reflex.Class (FunctorMaybe (..))
30+import Reflex.Patch (Additive, Group (..))
31+
32+newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }
33+ deriving (Eq, Ord, Show, Read, Typeable, Generic, Functor, Foldable, Traversable, Align)
34+
35+type instance (Index (AppendMap k m)) = k
36+type instance (IxValue (AppendMap k m)) = m
37+
38+instance Ord k => Ixed (AppendMap k m) where
39+ ix i = _Wrapped . ix i
40+
41+instance Ord k => At (AppendMap k m) where
42+ at i = _Wrapped . at i
43+
44+instance FunctorMaybe (AppendMap k) where
45+ fmapMaybe = mapMaybe
46+
47+-- | Deletes a key, returning 'Nothing' if the result is empty.
48+nonEmptyDelete :: Ord k => k -> AppendMap k a -> Maybe (AppendMap k a)
49+nonEmptyDelete k vs =
50+ let deleted = delete k vs
51+ in if Data.AppendMap.null deleted
52+ then Nothing
53+ else Just deleted
54+
55+mapMaybeNoNull :: (a -> Maybe b)
56+ -> AppendMap token a
57+ -> Maybe (AppendMap token b)
58+mapMaybeNoNull f as =
59+ let bs = fmapMaybe f as
60+ in if Data.AppendMap.null bs
61+ then Nothing
62+ else Just bs
63+
64+instance FunctorWithIndex k (AppendMap k) where
65+ imap f = AppendMap . imap f . _unAppendMap
66+ imapped = _Wrapped . imapped
67+
68+instance FoldableWithIndex k (AppendMap k) where
69+ ifolded = _Wrapped . ifolded
70+
71+instance TraversableWithIndex k (AppendMap k) where
72+ itraverse = itraverseOf itraversed
73+ itraversed = _Wrapped . itraversed
74+
75+instance (Ord k, Semigroup m) => Semigroup (AppendMap k m) where
76+ (AppendMap m0) <> (AppendMap m1) = AppendMap $ Map.unionWith (<>) m0 m1
77+
78+instance (Ord k, Semigroup m) => Monoid (AppendMap k m) where
79+ mempty = empty
80+ mappend = (<>)
81+
82+instance (Ord k, Group q) => Group (AppendMap k q) where
83+ negateG = map negateG
84+
85+instance (Ord k, Additive q) => Additive (AppendMap k q)
86+
87+(!) :: forall k a. Ord k => AppendMap k a -> k -> a
88+(!) = coerce ((Map.!) :: Map k a -> k -> a)
89+infixl 9 !
90+
91+(\\) :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
92+(\\) = coerce ((Map.\\) :: Map k a -> Map k b -> Map k a)
93+infixl 9 \\
94+
95+null :: forall k a. AppendMap k a -> Bool
96+null = coerce (Map.null :: Map k a -> Bool)
97+
98+size :: forall k a. AppendMap k a -> Int
99+size = coerce (Map.size :: Map k a -> Int)
100+
101+member :: forall k a. Ord k => k -> AppendMap k a -> Bool
102+member = coerce (Map.member :: k -> Map k a -> Bool)
103+
104+notMember :: forall k a. Ord k => k -> AppendMap k a -> Bool
105+notMember = coerce (Map.notMember :: k -> Map k a -> Bool)
106+
107+lookup :: forall k a. Ord k => k -> AppendMap k a -> Maybe a
108+lookup = coerce (Map.lookup :: k -> Map k a -> Maybe a)
109+
110+findWithDefault :: forall k a. Ord k => a -> k -> AppendMap k a -> a
111+findWithDefault = coerce (Map.findWithDefault :: a -> k -> Map k a -> a)
112+
113+lookupLT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
114+lookupLT = coerce (Map.lookupLT :: k -> Map k a -> Maybe (k,a))
115+
116+lookupGT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
117+lookupGT = coerce (Map.lookupGT :: k -> Map k a -> Maybe (k,a))
118+
119+lookupLE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
120+lookupLE = coerce (Map.lookupLE :: k -> Map k a -> Maybe (k,a))
121+
122+lookupGE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
123+lookupGE = coerce (Map.lookupGE :: k -> Map k a -> Maybe (k,a))
124+
125+empty :: forall k a. AppendMap k a
126+empty = coerce (Map.empty :: Map k a)
127+
128+singleton :: forall k a. k -> a -> AppendMap k a
129+singleton = coerce (Map.singleton :: k -> a -> Map k a)
130+
131+insert :: forall k a. Ord k => k -> a -> AppendMap k a -> AppendMap k a
132+insert = coerce (Map.insert :: k -> a -> Map k a -> Map k a)
133+
134+insertWith :: forall k a. Ord k => (a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
135+insertWith = coerce (Map.insertWith :: (a -> a -> a) -> k -> a -> Map k a -> Map k a)
136+
137+insertWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
138+insertWithKey = coerce (Map.insertWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a)
139+
140+insertLookupWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> (Maybe a, AppendMap k a)
141+insertLookupWithKey = coerce (Map.insertLookupWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a))
142+
143+delete :: forall k a. Ord k => k -> AppendMap k a -> AppendMap k a
144+delete = coerce (Map.delete :: k -> Map k a -> Map k a)
145+
146+adjust :: forall k a. Ord k => (a -> a) -> k -> AppendMap k a -> AppendMap k a
147+adjust = coerce (Map.adjust :: (a -> a) -> k -> Map k a -> Map k a)
148+
149+adjustWithKey :: forall k a. Ord k => (k -> a -> a) -> k -> AppendMap k a -> AppendMap k a
150+adjustWithKey = coerce (Map.adjustWithKey :: (k -> a -> a) -> k -> Map k a -> Map k a)
151+
152+update :: forall k a. Ord k => (a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
153+update = coerce (Map.update :: (a -> Maybe a) -> k -> Map k a -> Map k a)
154+
155+updateWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
156+updateWithKey = coerce (Map.updateWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> Map k a)
157+
158+updateLookupWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> (Maybe a, AppendMap k a)
159+updateLookupWithKey = coerce (Map.updateLookupWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a))
160+
161+alter :: forall k a. Ord k => (Maybe a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
162+alter = coerce (Map.alter :: (Maybe a -> Maybe a) -> k -> Map k a -> Map k a)
163+
164+unionWith :: forall k a. Ord k => (a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
165+unionWith = coerce (Map.unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a)
166+
167+unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
168+unionWithKey = coerce (Map.unionWithKey :: (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a)
169+
170+unionsWith :: forall k a. Ord k => (a -> a -> a) -> [AppendMap k a] -> AppendMap k a
171+unionsWith = coerce (Map.unionsWith :: (a -> a -> a) -> [Map k a] -> Map k a)
172+
173+difference :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
174+difference = (\\)
175+
176+differenceWith :: forall k a b. Ord k => (a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
177+differenceWith = coerce (Map.differenceWith :: (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
178+
179+differenceWithKey :: forall k a b. Ord k => (k -> a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
180+differenceWithKey = coerce (Map.differenceWithKey :: (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
181+
182+intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
183+intersectionWith = coerce (Map.intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c)
184+
185+intersectionWithKey :: forall k a b c. Ord k => (k -> a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
186+intersectionWithKey = coerce (Map.intersectionWithKey :: (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c)
187+
188+mergeWithKey :: forall k a b c. Ord k => (k -> a -> b -> Maybe c) -> (AppendMap k a -> AppendMap k c) -> (AppendMap k b -> AppendMap k c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
189+mergeWithKey = coerce (Map.mergeWithKey :: (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c)
190+
191+map :: (a -> b) -> AppendMap k a -> AppendMap k b
192+map = fmap
193+
194+mapWithKey :: (k -> a -> b) -> AppendMap k a -> AppendMap k b
195+mapWithKey = imap
196+
197+traverseWithKey :: Applicative t => (k -> a -> t b) -> AppendMap k a -> t (AppendMap k b)
198+traverseWithKey = itraverse
199+
200+mapAccum :: forall k a b c. (a -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
201+mapAccum = coerce (Map.mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
202+
203+mapAccumWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
204+mapAccumWithKey = coerce (Map.mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
205+
206+mapAccumRWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
207+mapAccumRWithKey = coerce (Map.mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
208+
209+mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
210+mapKeys = coerce (Map.mapKeys :: (k1 -> k2) -> Map k1 a -> Map k2 a)
211+
212+mapKeysWith :: forall k1 k2 a. Ord k2 => (a -> a -> a) -> (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
213+mapKeysWith = coerce (Map.mapKeysWith :: (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a)
214+
215+mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
216+mapKeysMonotonic = coerce (Map.mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a)
217+
218+foldr :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b
219+foldr = coerce (Map.foldr :: (a -> b -> b) -> b -> Map k a -> b)
220+
221+foldl :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a
222+foldl = coerce (Map.foldl :: (a -> b -> a) -> a -> Map k b -> a)
223+
224+foldrWithKey :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b
225+foldrWithKey = coerce (Map.foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b)
226+
227+foldlWithKey :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a
228+foldlWithKey = coerce (Map.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a)
229+
230+foldMapWithKey :: forall k a m. Monoid m => (k -> a -> m) -> AppendMap k a -> m
231+foldMapWithKey = coerce (Map.foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m)
232+
233+foldr' :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b
234+foldr' = coerce (Map.foldr' :: (a -> b -> b) -> b -> Map k a -> b)
235+
236+foldl' :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a
237+foldl' = coerce (Map.foldl' :: (a -> b -> a) -> a -> Map k b -> a)
238+
239+foldrWithKey' :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b
240+foldrWithKey' = coerce (Map.foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b)
241+
242+foldlWithKey' :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a
243+foldlWithKey' = coerce (Map.foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a)
244+
245+elems :: forall k a. AppendMap k a -> [a]
246+elems = coerce (Map.elems :: Map k a -> [a])
247+
248+keys :: forall k a. AppendMap k a -> [k]
249+keys = coerce (Map.keys :: Map k a -> [k])
250+
251+assocs :: forall k a. AppendMap k a -> [(k, a)]
252+assocs = coerce (Map.assocs :: Map k a -> [(k, a)])
253+
254+keysSet :: forall k a. AppendMap k a -> Set k
255+keysSet = coerce (Map.keysSet :: Map k a -> Set k)
256+
257+fromSet :: forall k a. (k -> a) -> Set k -> AppendMap k a
258+fromSet = coerce (Map.fromSet :: (k -> a) -> Set k -> Map k a)
259+
260+toList :: forall k a. AppendMap k a -> [(k, a)]
261+toList = coerce (Map.toList :: Map k a -> [(k, a)])
262+
263+fromList :: forall k a. Ord k => [(k, a)] -> AppendMap k a
264+fromList = coerce (Map.fromList :: [(k, a)] -> Map k a)
265+
266+fromListWith :: forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
267+fromListWith = coerce (Map.fromListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
268+
269+fromListWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
270+fromListWithKey = coerce (Map.fromListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
271+
272+toAscList :: forall k a. AppendMap k a -> [(k, a)]
273+toAscList = coerce (Map.toAscList :: Map k a -> [(k, a)])
274+
275+toDescList :: forall k a. AppendMap k a -> [(k, a)]
276+toDescList = coerce (Map.toDescList :: Map k a -> [(k, a)])
277+
278+fromAscList :: forall k a. Eq k => [(k, a)] -> AppendMap k a
279+fromAscList = coerce (Map.fromAscList :: [(k, a)] -> Map k a)
280+
281+fromAscListWith :: forall k a. Eq k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
282+fromAscListWith = coerce (Map.fromAscListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
283+
284+fromAscListWithKey :: forall k a. Eq k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
285+fromAscListWithKey = coerce (Map.fromAscListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
286+
287+fromDistinctAscList :: forall k a. [(k, a)] -> AppendMap k a
288+fromDistinctAscList = coerce (Map.fromDistinctAscList :: [(k, a)] -> Map k a)
289+
290+filter :: forall k a. (a -> Bool) -> AppendMap k a -> AppendMap k a
291+filter = coerce (Map.filter :: (a -> Bool) -> Map k a -> Map k a)
292+
293+filterWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> AppendMap k a
294+filterWithKey = coerce (Map.filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a)
295+
296+partition :: forall k a. (a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
297+partition = coerce (Map.partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a))
298+
299+partitionWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
300+partitionWithKey = coerce (Map.partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a))
301+
302+mapMaybe :: forall k a b. (a -> Maybe b) -> AppendMap k a -> AppendMap k b
303+mapMaybe = coerce (Map.mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b)
304+
305+mapMaybeWithKey :: forall k a b. (k -> a -> Maybe b) -> AppendMap k a -> AppendMap k b
306+mapMaybeWithKey = coerce (Map.mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b)
307+
308+mapEither :: forall k a b c. (a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
309+mapEither = coerce (Map.mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c))
310+
311+mapEitherWithKey :: forall k a b c. (k -> a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
312+mapEitherWithKey = coerce (Map.mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c))
313+
314+split :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, AppendMap k a)
315+split = coerce (Map.split :: k -> Map k a -> (Map k a, Map k a))
316+
317+splitLookup :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, Maybe a, AppendMap k a)
318+splitLookup = coerce (Map.splitLookup :: k -> Map k a -> (Map k a, Maybe a, Map k a))
319+
320+splitRoot :: forall k a. AppendMap k a -> [AppendMap k a]
321+splitRoot = coerce (Map.splitRoot :: Map k a -> [Map k a])
322+
323+isSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
324+isSubmapOf = coerce (Map.isSubmapOf :: Map k a -> Map k a -> Bool)
325+
326+isSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
327+isSubmapOfBy = coerce (Map.isSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
328+
329+isProperSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
330+isProperSubmapOf = coerce (Map.isProperSubmapOf :: Map k a -> Map k a -> Bool)
331+
332+isProperSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
333+isProperSubmapOfBy = coerce (Map.isProperSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
334+
335+lookupIndex :: forall k a. Ord k => k -> AppendMap k a -> Maybe Int
336+lookupIndex = coerce (Map.lookupIndex :: k -> Map k a -> Maybe Int)
337+
338+findIndex :: forall k a. Ord k => k -> AppendMap k a -> Int
339+findIndex = coerce (Map.findIndex :: k -> Map k a -> Int)
340+
341+elemAt :: forall k a. Int -> AppendMap k a -> (k, a)
342+elemAt = coerce (Map.elemAt :: Int -> Map k a -> (k, a))
343+
344+updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> AppendMap k a -> AppendMap k a
345+updateAt = coerce (Map.updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a)
346+
347+deleteAt :: forall k a. Int -> AppendMap k a -> AppendMap k a
348+deleteAt = coerce (Map.deleteAt :: Int -> Map k a -> Map k a)
349+
350+findMin :: forall k a. AppendMap k a -> (k, a)
351+findMin = coerce (Map.findMin :: Map k a -> (k, a))
352+
353+findMax :: forall k a. AppendMap k a -> (k, a)
354+findMax = coerce (Map.findMax :: Map k a -> (k, a))
355+
356+deleteMin :: forall k a. AppendMap k a -> AppendMap k a
357+deleteMin = coerce (Map.deleteMin :: Map k a -> Map k a)
358+
359+deleteMax :: forall k a. AppendMap k a -> AppendMap k a
360+deleteMax = coerce (Map.deleteMax :: Map k a -> Map k a)
361+
362+deleteFindMin :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
363+deleteFindMin = coerce (Map.deleteFindMin :: Map k a -> ((k, a), Map k a))
364+
365+deleteFindMax :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
366+deleteFindMax = coerce (Map.deleteFindMax :: Map k a -> ((k, a), Map k a))
367+
368+updateMin :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a
369+updateMin = coerce (Map.updateMin :: (a -> Maybe a) -> Map k a -> Map k a)
370+
371+updateMax :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a
372+updateMax = coerce (Map.updateMax :: (a -> Maybe a) -> Map k a -> Map k a)
373+
374+updateMinWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
375+updateMinWithKey = coerce (Map.updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
376+
377+updateMaxWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
378+updateMaxWithKey = coerce (Map.updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
379+
380+minView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
381+minView = coerce (Map.minView :: Map k a -> Maybe (a, Map k a))
382+
383+maxView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
384+maxView = coerce (Map.maxView :: Map k a -> Maybe (a, Map k a))
385+
386+minViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
387+minViewWithKey = coerce (Map.minViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
388+
389+maxViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
390+maxViewWithKey = coerce (Map.maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
391+
392+showTree :: forall k a. (Show k, Show a) => AppendMap k a -> String
393+showTree = coerce (Map.showTree :: (Show k, Show a) => Map k a -> String)
394+
395+showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> AppendMap k a -> String
396+showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)
397+
398+valid :: forall k a. Ord k => AppendMap k a -> Bool
399+valid = coerce (Map.valid :: Ord k => Map k a -> Bool)
400+
401+instance Default (AppendMap k a) where
402+ def = empty
403+
404+instance AppendMap k' v' ~ t => Rewrapped (AppendMap k a) t
405+
406+instance Wrapped (AppendMap k a) where
407+ type Unwrapped (AppendMap k a) = Map k a
408+ _Wrapped' = iso (\(AppendMap m) -> m) AppendMap
src/Data/FastMutableIntMap.hsnew file+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+138−24
@@ -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,54 @@ 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'.
295+#if MIN_VERSION_transformers(5,2,0)
228newtype ComposeMaybe f a =
296newtype ComposeMaybe f a =
297+#else
298+newtype ComposeMaybe (f :: * -> *) (a :: *) =
299+#endif
229− ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
300+ ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
230
301
231deriving instance Functor f => Functor (ComposeMaybe f)
302deriving instance Functor f => Functor (ComposeMaybe f)
303+
304+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
305+instance {-# INCOHERENT #-} EqTag f g => EqTag f (ComposeMaybe g) where
306+ eqTagToEq f _ = eqTagToEq f (Proxy :: Proxy g)
307+
308+instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where
309+ showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)
310+#endif
311+--------------------------------------------------------------------------------
312+-- Deprecated functions
313+--------------------------------------------------------------------------------
314+
315+{-# INLINE sequenceDmap #-}
316+{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}
317+-- | Run the actions contained in the 'DMap'
318+sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)
319+sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t
320+
321+{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}
322+-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor
323+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
324+wrapDMap f = DMap.map $ f . runIdentity
325+
326+{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}
327+-- | Replace one functor for a 'DMap''s values with a different functor
328+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
329+rewrapDMap = DMap.map
330+
331+{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}
332+-- | Replace one functor for a 'DMap''s values with the 'Identity' functor
333+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
334+unwrapDMap f = DMap.map $ Identity . f
335+
336+{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}
337+-- | Like 'unwrapDMap', but possibly delete some values from the DMap
338+unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
339+unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a
340+
341+{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}
342+-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the
343+-- underlying functor
344+extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
345+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+27
@@ -0,0 +1,27 @@
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.Profiled as X
21+import Reflex.Query.Base as X
22+import Reflex.Query.Class as X
23+import Reflex.Requester.Base as X
24+import Reflex.Requester.Class as X
25+import Reflex.Spider as X
26+import Reflex.TriggerEvent.Base as X
27+import Reflex.TriggerEvent.Class as X
src/Reflex/Class.hsnew file+1227
@@ -0,0 +1,1227 @@
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+ , accumDyn
82+ , accumMDyn
83+ , accumMaybeDyn
84+ , accumMaybeMDyn
85+ , mapAccumDyn
86+ , mapAccumMDyn
87+ , mapAccumMaybeDyn
88+ , mapAccumMaybeMDyn
89+ , accumB
90+ , accumMB
91+ , accumMaybeB
92+ , accumMaybeMB
93+ , mapAccumB
94+ , mapAccumMB
95+ , mapAccumMaybeB
96+ , mapAccumMaybeMB
97+ , mapAccum_
98+ , mapAccumM_
99+ , mapAccumMaybe_
100+ , mapAccumMaybeM_
101+ , zipListWithEvent
102+ , numberOccurrences
103+ , numberOccurrencesFrom
104+ , numberOccurrencesFrom_
105+ , (<@>)
106+ , (<@)
107+ , tailE
108+ , headTailE
109+ , takeWhileE
110+ , switcher
111+ -- * Debugging functions
112+ , traceEvent
113+ , traceEventWith
114+ -- * Unsafe functions
115+ , unsafeDynamic
116+ , unsafeMapIncremental
117+ -- * 'FunctorMaybe'
118+ , FunctorMaybe (..)
119+ , fforMaybe
120+ , ffilter
121+ -- * Miscellaneous convenience functions
122+ , ffor
123+ , MonadAdjust (..)
124+ , sequenceDMapWithAdjust
125+ , sequenceDMapWithAdjustWithMove
126+ , mapMapWithAdjustWithMove
127+ -- * Deprecated functions
128+ , appendEvents
129+ , onceE
130+ , sequenceThese
131+ , fmapMaybeCheap
132+ , fmapCheap
133+ , fforCheap
134+ , fforMaybeCheap
135+ , pushAlwaysCheap
136+ , tagCheap
137+ , mergeWithCheap
138+ , mergeWithCheap'
139+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
140+ , Spider
141+ , SpiderEnv
142+ , SpiderTimeline
143+ , Global
144+ , Behavior (..)
145+ , Event (..)
146+ , Dynamic (..)
147+ , Incremental (..)
148+ , never
149+ , constant
150+ , push
151+ , pushCheap
152+ , pull
153+ , merge
154+ , fan
155+ , switch
156+ , coincidence
157+ , current
158+ , updated
159+ , unsafeBuildDynamic
160+ , unsafeBuildIncremental
161+ , mergeIncremental
162+ , mergeIncrementalWithMove
163+ , currentIncremental
164+ , updatedIncremental
165+ , incrementalToDynamic
166+ , behaviorCoercion
167+ , eventCoercion
168+ , dynamicCoercion
169+#endif
170+ ) where
171+
172+import Control.Applicative
173+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
174+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
175+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
176+import Control.Monad.Trans.Cont (ContT ())
177+import Control.Monad.Trans.Except (ExceptT ())
178+import Control.Monad.Trans.RWS (RWST ())
179+import Control.Monad.Trans.Writer (WriterT ())
180+import Data.Align
181+import Data.Bifunctor
182+import Data.Coerce
183+import Data.Default
184+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
185+import qualified Data.Dependent.Map as DMap
186+import Data.Either
187+import Data.Foldable
188+import Data.Functor.Bind hiding (join)
189+import qualified Data.Functor.Bind as Bind
190+import Data.Functor.Constant
191+import Data.Functor.Misc
192+import Data.Functor.Plus
193+import Data.IntMap.Strict (IntMap)
194+import qualified Data.IntMap.Strict as IntMap
195+import Data.List.NonEmpty (NonEmpty (..))
196+import Data.Map (Map)
197+import Data.Maybe
198+import Data.Monoid hiding (Alt, (<>))
199+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
200+import Data.String
201+import Data.These
202+import Data.Traversable
203+import Data.Type.Coercion
204+import Reflex.FunctorMaybe
205+import Reflex.Patch
206+import Data.FastMutableIntMap (PatchIntMap)
207+
208+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
209+import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),
210+ SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,
211+ dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,
212+ dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,
213+ runFrame, runSpiderHostFrame)
214+import qualified Reflex.Spider.Internal
215+import qualified Reflex.Spider.Internal as S
216+import Unsafe.Coerce
217+#endif
218+
219+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
220+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
221+
222+import Debug.Trace (trace)
223+
224+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
225+#include "Spider/SpiderTimeline.include.hs"
226+#endif
227+
228+-- | The 'Reflex' class contains all the primitive functionality needed for
229+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates
230+-- which "timeline" is in use. Timelines are fully-independent FRP contexts,
231+-- and the type of the timeline determines the FRP engine to be used. For most
232+-- purposes, the 'Reflex.Spider' implementation is recommended.
233+class ( MonadHold t (PushM t)
234+ , MonadSample t (PullM t)
235+ , MonadFix (PushM t)
236+ , Functor (Dynamic t)
237+ , Applicative (Dynamic t) -- Necessary for GHC <= 7.8
238+ , Monad (Dynamic t)
239+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
240+ , t ~ SpiderTimeline Global
241+#endif
242+ ) => Reflex t where
243+ -- | A container for a value that can change over time. 'Behavior's can be
244+ -- sampled at will, but it is not possible to be notified when they change
245+ data Behavior t :: * -> *
246+ -- | A stream of occurrences. During any given frame, an 'Event' is either
247+ -- occurring or not occurring; if it is occurring, it will contain a value of
248+ -- the given type (its "occurrence type")
249+ data Event t :: * -> *
250+ -- | A container for a value that can change over time and allows
251+ -- notifications on changes. Basically a combination of a 'Behavior' and an
252+ -- 'Event', with a rule that the 'Behavior' will change if and only if the
253+ -- 'Event' fires.
254+ data Dynamic t :: * -> *
255+ -- | An 'Incremental' is a more general form of a 'Dynamic'.
256+ -- Instead of always fully replacing the value, only parts of it can be patched.
257+ -- This is only needed for performance critical code via `mergeIncremental` to make small
258+ -- changes to large values.
259+ data Incremental t :: * -> *
260+ -- | A monad for doing complex push-based calculations efficiently
261+ type PushM t :: * -> *
262+ -- | A monad for doing complex pull-based calculations efficiently
263+ type PullM t :: * -> *
264+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
265+ -- | An 'Event' with no occurrences
266+ never :: Event t a
267+ -- | Create a 'Behavior' that always has the given value
268+ 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
269+ -- | Create an 'Event' from another 'Event'; the provided function can sample
270+ -- 'Behavior's and hold 'Event's, and use the results to produce a occurring
271+ -- (Just) or non-occurring (Nothing) result
272+ push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
273+ -- | 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.
274+ pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
275+ -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be
276+ -- recomputed whenever any of the read 'Behavior's changes
277+ pull :: PullM t a -> Behavior t a
278+ -- | Merge a collection of events; the resulting 'Event' will only occur if at
279+ -- least one input event is occuring, and will contain all of the input keys
280+ -- that are occurring simultaneously
281+ 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
282+ -- | Efficiently fan-out an event to many destinations. This function should
283+ -- be partially applied, and then the result applied repeatedly to create
284+ -- child events
285+ 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
286+ -- | Create an 'Event' that will occur whenever the currently-selected input
287+ -- 'Event' occurs
288+ switch :: Behavior t (Event t a) -> Event t a
289+ -- | Create an 'Event' that will occur whenever the input event is occurring
290+ -- and its occurrence value, another 'Event', is also occurring
291+ coincidence :: Event t (Event t a) -> Event t a
292+ -- | Extract the 'Behavior' of a 'Dynamic'.
293+ current :: Dynamic t a -> Behavior t a
294+ -- | Extract the 'Event' of the 'Dynamic'.
295+ updated :: Dynamic t a -> Event t a
296+ -- | Create a new 'Dynamic'. The given 'PullM' must always return the most
297+ -- recent firing of the given 'Event', if any.
298+ unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
299+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change
300+ -- in the same way that the accumulated application of patches would change
301+ -- that value.
302+ unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
303+ -- | Create a merge whose parents can change over time
304+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
305+ -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
306+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
307+ -- | Extract the 'Behavior' component of an 'Incremental'
308+ currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
309+ -- | Extract the 'Event' component of an 'Incremental'
310+ updatedIncremental :: Patch p => Incremental t p -> Event t p
311+ -- | Convert an 'Incremental' to a 'Dynamic'
312+ incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)
313+ -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its
314+ -- occurrence type
315+ behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)
316+ -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its
317+ -- occurrence type
318+ eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)
319+ -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
320+ -- occurrence type
321+ dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
322+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
323+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a
324+#endif
325+
326+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
327+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
328+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
329+
330+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
331+instance t ~ SpiderTimeline Global => Reflex t where
332+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }
333+ newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }
334+ newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Reflex.Spider.Internal.Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)
335+ newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Reflex.Spider.Internal.Dynamic Global p }
336+ type PullM t = SpiderPullM Global
337+ type PushM t = SpiderPushM Global
338+never :: Reflex t => Event t a
339+constant :: Reflex t => a -> Behavior t a
340+push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b
341+pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b
342+pull :: Reflex t => PullM t a -> Behavior t a
343+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
344+fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k
345+switch :: Reflex t => Behavior t (Event t a) -> Event t a
346+coincidence :: Reflex t => Event t (Event t a) -> Event t a
347+current :: Reflex t => Dynamic t a -> Behavior t a
348+updated :: Reflex t => Dynamic t a -> Event t a
349+unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a
350+unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p
351+mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
352+mergeIncrementalWithMove :: (Reflex t, GCompare k) => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
353+currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)
354+updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p
355+incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)
356+behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)
357+eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)
358+dynamicCoercion :: Reflex t => Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
359+{-# INLINE never #-}
360+never = SpiderEvent S.eventNever
361+{-# INLINE constant #-}
362+constant = SpiderBehavior . S.behaviorConst
363+{-# INLINE push #-}
364+push f = SpiderEvent . S.push (coerce f) . unSpiderEvent
365+{-# INLINE pushCheap #-}
366+pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent
367+{-# INLINE pull #-}
368+pull = SpiderBehavior . S.pull . coerce
369+{-# INLINE merge #-}
370+merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))
371+{-# INLINE fan #-}
372+fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))
373+{-# INLINE switch #-}
374+switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior
375+{-# INLINE coincidence #-}
376+coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent
377+{-# INLINE current #-}
378+current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic
379+{-# INLINE updated #-}
380+updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic
381+{-# INLINE unsafeBuildDynamic #-}
382+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
383+{-# INLINE unsafeBuildIncremental #-}
384+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ S.unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
385+{-# INLINE mergeIncremental #-}
386+mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental
387+{-# INLINE mergeIncrementalWithMove #-}
388+mergeIncrementalWithMove = SpiderEvent . S.mergeWithMove . (unsafeCoerce :: S.Dynamic x (PatchDMapWithMove k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMapWithMove k (S.Event x))) . unSpiderIncremental
389+{-# INLINE currentIncremental #-}
390+currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
391+{-# INLINE updatedIncremental #-}
392+updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
393+{-# INLINE incrementalToDynamic #-}
394+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do
395+ c <- readBehaviorUntracked $ dynamicCurrent i
396+ return $ Identity <$> apply p c
397+eventCoercion Coercion = Coercion
398+behaviorCoercion Coercion = Coercion
399+dynamicCoercion = unsafeCoerce
400+#endif
401+
402+-- | Coerce a 'Behavior' between representationally-equivalent value types
403+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b
404+coerceBehavior = coerceWith $ behaviorCoercion Coercion
405+
406+-- | Coerce an 'Event' between representationally-equivalent occurrence types
407+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b
408+coerceEvent = coerceWith $ eventCoercion Coercion
409+
410+-- | Coerce a 'Dynamic' between representationally-equivalent value types
411+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
412+coerceDynamic = coerceWith $ dynamicCoercion Coercion
413+
414+-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
415+-- _must_ change when and only when the 'Event' fires, such that the
416+-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
417+-- if this is not the case, the resulting 'Dynamic' will behave
418+-- nondeterministically.
419+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
420+unsafeDynamic = unsafeBuildDynamic . sample
421+
422+-- | Construct a 'Dynamic' value that never changes
423+constDyn :: Reflex t => a -> Dynamic t a
424+constDyn = pure
425+
426+instance (Reflex t, Default a) => Default (Dynamic t a) where
427+ def = pure def
428+
429+-- | 'MonadSample' designates monads that can read the current value of a
430+-- 'Behavior'. This includes both 'PullM' and 'PushM'.
431+class (Applicative m, Monad m) => MonadSample t m | m -> t where
432+ -- | Get the current value in the 'Behavior'
433+ sample :: Behavior t a -> m a
434+
435+-- | 'MonadHold' designates monads that can create new 'Behavior's based on
436+-- 'Event's; usually this will be 'PushM' or a monad based on it. 'MonadHold'
437+-- is required to create any stateful computations with Reflex.
438+class MonadSample t m => MonadHold t m where
439+ -- | Create a new 'Behavior' whose value will initially be equal to the given
440+ -- value and will be updated whenever the given 'Event' occurs. The update
441+ -- takes effect immediately after the 'Event' occurs; if the occurrence that
442+ -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample
443+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new
444+ -- one.
445+ hold :: a -> Event t a -> m (Behavior t a)
446+ default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)
447+ hold v0 = lift . hold v0
448+ -- | Create a 'Dynamic' value using the given initial value that changes every
449+ -- time the 'Event' occurs.
450+ holdDyn :: a -> Event t a -> m (Dynamic t a)
451+ default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)
452+ holdDyn v0 = lift . holdDyn v0
453+ -- | Create an 'Incremental' value using the given initial value that changes
454+ -- every time the 'Event' occurs.
455+ holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
456+ default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
457+ holdIncremental v0 = lift . holdIncremental v0
458+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)
459+ default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
460+ buildDynamic getV0 = lift . buildDynamic getV0
461+ -- | Create a new 'Event' that only occurs only once, on the first occurence of
462+ -- the supplied 'Event'.
463+ headE :: Event t a -> m (Event t a)
464+ default headE :: (Reflex t, MonadFix m) => Event t a -> m (Event t a)
465+ headE e = do
466+ rec be <- hold e $ fmapCheap (const never) e'
467+ let e' = switch be
468+ return e'
469+
470+-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a
471+-- key. This is much more efficient than filtering for each key with
472+-- 'fmapMaybe'.
473+newtype EventSelector t k = EventSelector
474+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
475+ -- determined by the type of the key, so this can be used to fan-out
476+ -- 'Event's whose sub-'Event's have different types.
477+ --
478+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
479+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant
480+ -- occurrences of an 'Event'.
481+ select :: forall a. k a -> Event t a
482+ }
483+
484+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
485+
486+--------------------------------------------------------------------------------
487+-- Instances
488+--------------------------------------------------------------------------------
489+
490+instance MonadSample t m => MonadSample t (ReaderT r m) where
491+ sample = lift . sample
492+
493+instance MonadHold t m => MonadHold t (ReaderT r m) where
494+ hold a0 = lift . hold a0
495+ holdDyn a0 = lift . holdDyn a0
496+ holdIncremental a0 = lift . holdIncremental a0
497+ buildDynamic a0 = lift . buildDynamic a0
498+ headE = lift . headE
499+
500+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
501+ sample = lift . sample
502+
503+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
504+ hold a0 = lift . hold a0
505+ holdDyn a0 = lift . holdDyn a0
506+ holdIncremental a0 = lift . holdIncremental a0
507+ buildDynamic a0 = lift . buildDynamic a0
508+ headE = lift . headE
509+
510+instance MonadSample t m => MonadSample t (StateT s m) where
511+ sample = lift . sample
512+
513+instance MonadHold t m => MonadHold t (StateT s m) where
514+ hold a0 = lift . hold a0
515+ holdDyn a0 = lift . holdDyn a0
516+ holdIncremental a0 = lift . holdIncremental a0
517+ buildDynamic a0 = lift . buildDynamic a0
518+ headE = lift . headE
519+
520+instance MonadSample t m => MonadSample t (ExceptT e m) where
521+ sample = lift . sample
522+
523+instance MonadHold t m => MonadHold t (ExceptT e m) where
524+ hold a0 = lift . hold a0
525+ holdDyn a0 = lift . holdDyn a0
526+ holdIncremental a0 = lift . holdIncremental a0
527+ buildDynamic a0 = lift . buildDynamic a0
528+ headE = lift . headE
529+
530+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
531+ sample = lift . sample
532+
533+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
534+ hold a0 = lift . hold a0
535+ holdDyn a0 = lift . holdDyn a0
536+ holdIncremental a0 = lift . holdIncremental a0
537+ buildDynamic a0 = lift . buildDynamic a0
538+ headE = lift . headE
539+
540+instance MonadSample t m => MonadSample t (ContT r m) where
541+ sample = lift . sample
542+
543+instance MonadHold t m => MonadHold t (ContT r m) where
544+ hold a0 = lift . hold a0
545+ holdDyn a0 = lift . holdDyn a0
546+ holdIncremental a0 = lift . holdIncremental a0
547+ buildDynamic a0 = lift . buildDynamic a0
548+ headE = lift . headE
549+
550+--------------------------------------------------------------------------------
551+-- Convenience functions
552+--------------------------------------------------------------------------------
553+
554+-- | Create an 'Event' from another 'Event'. The provided function can sample
555+-- 'Behavior's and hold 'Event's.
556+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
557+pushAlways f = push (fmap Just . f)
558+
559+-- | Flipped version of 'fmap'.
560+ffor :: Functor f => f a -> (a -> b) -> f b
561+ffor = flip fmap
562+
563+instance Reflex t => Applicative (Behavior t) where
564+ pure = constant
565+ f <*> x = pull $ sample f `ap` sample x
566+ _ *> b = b
567+ a <* _ = a
568+
569+instance Reflex t => Apply (Behavior t) where
570+ (<.>) = (<*>)
571+
572+instance Reflex t => Bind (Behavior t) where
573+ (>>-) = (>>=)
574+
575+instance (Reflex t, Fractional a) => Fractional (Behavior t a) where
576+ (/) = liftA2 (/)
577+ fromRational = pure . fromRational
578+ recip = fmap recip
579+
580+instance Reflex t => Functor (Behavior t) where
581+ fmap f = pull . fmap f . sample
582+
583+instance (Reflex t, IsString a) => IsString (Behavior t a) where
584+ fromString = pure . fromString
585+
586+instance Reflex t => Monad (Behavior t) where
587+ a >>= f = pull $ sample a >>= sample . f
588+ -- 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.
589+ return = constant
590+ fail = error "Monad (Behavior t) does not support fail"
591+
592+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
593+ mempty = constant mempty
594+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
595+ mconcat = pull . fmap mconcat . mapM sample
596+
597+instance (Reflex t, Num a) => Num (Behavior t a) where
598+ (+) = liftA2 (+)
599+ (-) = liftA2 (-)
600+ (*) = liftA2 (*)
601+ abs = fmap abs
602+ fromInteger = pure . fromInteger
603+ negate = fmap negate
604+ signum = fmap signum
605+
606+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
607+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
608+ sconcat = pull . fmap sconcat . mapM sample
609+#if MIN_VERSION_semigroups(0,17,0)
610+ stimes n = fmap $ stimes n
611+#else
612+ times1p n = fmap $ times1p n
613+#endif
614+
615+-- | Flipped version of 'fmapMaybe'.
616+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
617+fforMaybe = flip fmapMaybe
618+
619+-- | Filter 'f a' using the provided predicate.
620+-- Relies on 'fforMaybe'.
621+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
622+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
623+
624+-- | Left-biased event union (prefers left event on simultaneous
625+-- occurrence).
626+instance Reflex t => Alt (Event t) where
627+ ev1 <!> ev2 = leftmost [ev1, ev2]
628+
629+-- | 'Event' intersection (convenient interface to 'coincidence').
630+instance Reflex t => Apply (Event t) where
631+ evf <.> evx = coincidence (fmap (<$> evx) evf)
632+
633+-- | 'Event' intersection (convenient interface to 'coincidence').
634+instance Reflex t => Bind (Event t) where
635+ evx >>- f = coincidence (f <$> evx)
636+ join = coincidence
637+
638+instance Reflex t => Functor (Event t) where
639+ {-# INLINE fmap #-}
640+ fmap f = fmapMaybe $ Just . f
641+
642+instance Reflex t => FunctorMaybe (Event t) where
643+ {-# INLINE fmapMaybe #-}
644+ fmapMaybe f = push $ return . f
645+
646+-- | Never: @'zero' = 'never'@.
647+instance Reflex t => Plus (Event t) where
648+ zero = never
649+
650+-- | Replace each occurrence value of the 'Event' with the value of the
651+-- 'Behavior' at the time of that occurrence.
652+tag :: Reflex t => Behavior t b -> Event t a -> Event t b
653+tag b = pushAlways $ \_ -> sample b
654+
655+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the
656+-- current value of the 'Behavior'.
657+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
658+attach = attachWith (,)
659+
660+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by
661+-- combining it with the current value of the 'Behavior'.
662+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
663+attachWith f = attachWithMaybe $ \a b -> Just $ f a b
664+
665+-- | Create a new 'Event' by combining each occurence with the current value of
666+-- the 'Behavior'. The occurrence is discarded if the combining function returns
667+-- Nothing
668+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
669+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
670+
671+-- | Create a new 'Event' that occurs on all but the first occurence of the
672+-- supplied 'Event'.
673+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
674+tailE e = snd <$> headTailE e
675+
676+-- | Create a tuple of two 'Event's with the first one occuring only the first
677+-- time the supplied 'Event' occurs and the second occuring on all but the first
678+-- occurence.
679+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
680+headTailE e = do
681+ eHead <- headE e
682+ be <- hold never $ fmap (const e) eHead
683+ return (eHead, switch be)
684+
685+-- | Starting at the current time, fire all the occurrences of the 'Event' for
686+-- which the given predicate returns 'True'. When 'False' is returned, do not
687+-- fire, and permanently stop firing, even if 'True' values are encountered
688+-- later.
689+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)
690+takeWhileE f e = do
691+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a
692+ then Right a
693+ else Left never
694+ be <- hold e eFalse
695+ let e' = switch be
696+ return eTrue
697+
698+-- | Split the supplied 'Event' into two individual 'Event's occuring at the
699+-- same time with the respective values from the tuple.
700+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
701+splitE e = (fmap fst e, fmap snd e)
702+
703+-- | Print the supplied 'String' and the value of the 'Event' on each
704+-- occurence. This should /only/ be used for debugging.
705+--
706+-- Note: As with Debug.Trace.trace, the message will only be printed if the
707+-- 'Event' is actually used.
708+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
709+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
710+
711+-- | Print the output of the supplied function on each occurence of the
712+-- 'Event'. This should /only/ be used for debugging.
713+--
714+-- Note: As with Debug.Trace.trace, the message will only be printed if the
715+-- 'Event' is actually used.
716+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
717+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
718+
719+instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
720+ (<>) = alignWith (mergeThese (<>))
721+ sconcat = fmap sconcat . mergeList . toList
722+#if MIN_VERSION_semigroups(0,17,0)
723+ stimes n = fmap $ stimes n
724+#else
725+ times1p n = fmap $ times1p n
726+#endif
727+
728+instance (Semigroup a, Reflex t) => Monoid (Event t a) where
729+ mempty = never
730+ mappend = (<>)
731+ mconcat = fmap sconcat . mergeList
732+
733+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
734+-- list occurs. If multiple occur at the same time they are folded from the left
735+-- with the given function.
736+{-# INLINE mergeWith #-}
737+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
738+mergeWith = mergeWith' id
739+
740+{-# INLINE mergeWith' #-}
741+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
742+mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)
743+ . mergeInt
744+ . IntMap.fromDistinctAscList
745+ $ zip [0 :: Int ..] es
746+
747+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
748+-- list occurs. If multiple occur at the same time the value is the value of the
749+-- leftmost event.
750+{-# INLINE leftmost #-}
751+leftmost :: Reflex t => [Event t a] -> Event t a
752+leftmost = mergeWith const
753+
754+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
755+-- list occurs and has a list of the values of all 'Event's occuring at that
756+-- time.
757+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
758+mergeList [] = never
759+mergeList es = mergeWithFoldCheap' id es
760+
761+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
762+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
763+
764+-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
765+-- occurs if at least one of them occurs and has a map of values of all 'Event's
766+-- occuring at that time.
767+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
768+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
769+
770+-- | Create a merge whose parents can change over time
771+mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
772+mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
773+
774+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
775+mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)
776+mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)
777+
778+-- | Split the event into separate events for 'Left' and 'Right' values.
779+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)
780+fanEither e =
781+ let justLeft = either Just (const Nothing)
782+ justRight = either (const Nothing) Just
783+ in (fmapMaybe justLeft e, fmapMaybe justRight e)
784+
785+-- | Split the event into separate events for 'This' and 'That' values,
786+-- allowing them to fire simultaneously when the input value is 'These'.
787+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)
788+fanThese e =
789+ let this (This x) = Just x
790+ this (These x _) = Just x
791+ this _ = Nothing
792+ that (That y) = Just y
793+ that (These _ y) = Just y
794+ that _ = Nothing
795+ in (fmapMaybe this e, fmapMaybe that e)
796+
797+-- | Split the event into an 'EventSelector' that allows efficient selection of
798+-- the individual 'Event's.
799+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
800+fanMap = fan . fmap mapToDMap
801+
802+-- | Switches to the new event whenever it receives one. Whenever a new event
803+-- is provided, if it is firing, its value will be the resulting event's value;
804+-- if it is not firing, but the old one is, the old one's value will be used.
805+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
806+switchPromptly ea0 eea = do
807+ bea <- hold ea0 eea
808+ let eLag = switch bea
809+ eCoincidences = coincidence eea
810+ return $ leftmost [eCoincidences, eLag]
811+
812+-- | 'switch'es to a new event whenever it receives one. At the moment of
813+-- switching, the old event will be ignored if it fires, and the new one will be
814+-- used if it fires; this is the opposite of 'switch', which will use only the
815+-- old value.
816+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
817+switchPromptOnly e0 e' = do
818+ eLag <- switch <$> hold e0 e'
819+ return $ coincidence $ leftmost [e', eLag <$ eLag]
820+
821+instance Reflex t => Align (Event t) where
822+ nil = never
823+ align = alignEventWithMaybe Just
824+
825+-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
826+-- the 'Behavior' is true at the time of occurence.
827+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
828+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
829+
830+-- | Create a new behavior given a starting behavior and switch to a the behvior
831+-- carried by the event when it fires.
832+switcher :: (Reflex t, MonadHold t m)
833+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
834+switcher b eb = pull . (sample <=< sample) <$> hold b eb
835+
836+-- | Combine two 'Dynamic's. The result will change whenever either (or both)
837+-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.
838+zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)
839+zipDyn = zipDynWith (,)
840+
841+-- | Combine two 'Dynamic's with a combining function. The result will change
842+-- whenever either (or both) input 'Dynamic' changes.
843+-- More efficient than liftA2.
844+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
845+zipDynWith f da db =
846+ let eab = align (updated da) (updated db)
847+ ec = flip push eab $ \o -> do
848+ (a, b) <- case o of
849+ This a -> do
850+ b <- sample $ current db
851+ return (a, b)
852+ That b -> do
853+ a <- sample $ current da
854+ return (a, b)
855+ These a b -> return (a, b)
856+ return $ Just $ f a b
857+ in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
858+
859+instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
860+ mconcat = distributeListOverDynWith mconcat
861+ mempty = constDyn mempty
862+ mappend = zipDynWith mappend
863+
864+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
865+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
866+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.
867+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
868+distributeDMapOverDynPure dm = case DMap.toList dm of
869+ [] -> constDyn DMap.empty
870+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
871+ _ ->
872+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
873+ edmPre = merge $ DMap.map updated dm
874+ result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
875+ olds <- sample $ current result
876+ return $ DMap.unionWithKey (\_ _ new -> new) olds news
877+ in result
878+
879+-- | Convert a list of 'Dynamic's into a 'Dynamic' list.
880+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
881+distributeListOverDyn = distributeListOverDynWith id
882+
883+-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
884+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b
885+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
886+
887+-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
888+-- unless the second supplied 'Event' occurs simultaneously.
889+difference :: Reflex t => Event t a -> Event t b -> Event t a
890+difference = alignEventWithMaybe $ \case
891+ This a -> Just a
892+ _ -> Nothing
893+
894+alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c
895+alignEventWithMaybe f ea eb =
896+ fmapMaybe (f <=< dmapToThese)
897+ $ merge
898+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
899+
900+
901+--------------------------------------------------------------------------------
902+-- Accumulator
903+--------------------------------------------------------------------------------
904+
905+-- | An 'Accumulator' type can be built by accumulating occurrences of an
906+-- 'Event'.
907+#if __GLASGOW_HASKELL__ < 802
908+{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
909+{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
910+{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
911+{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
912+#endif
913+class Reflex t => Accumulator t f | f -> t where
914+ accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
915+ accum f = accumMaybe $ \v o -> Just $ f v o
916+ accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
917+ accumM f = accumMaybeM $ \v o -> Just <$> f v o
918+ accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
919+ accumMaybe f = accumMaybeM $ \v o -> return $ f v o
920+ accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
921+ mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
922+ mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
923+ mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
924+ mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
925+ mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
926+ mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
927+ mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
928+
929+accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)
930+accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o
931+accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)
932+accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o
933+accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)
934+accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o
935+accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
936+accumMaybeMDyn f z e = do
937+ rec let e' = flip push e $ \o -> do
938+ v <- sample $ current d'
939+ f v o
940+ d' <- holdDyn z e'
941+ return d'
942+mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
943+mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o
944+mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
945+mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o
946+mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
947+mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o
948+mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
949+mapAccumMaybeMDyn f z e = do
950+ rec let e' = flip push e $ \o -> do
951+ v <- sample $ current d'
952+ result <- f v o
953+ return $ case result of
954+ (Nothing, Nothing) -> Nothing
955+ _ -> Just result
956+ d' <- holdDyn z $ fmapMaybe fst e'
957+ return (d', fmapMaybe snd e')
958+
959+accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)
960+accumB f = accumMaybeB $ \v o -> Just $ f v o
961+accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)
962+accumMB f = accumMaybeMB $ \v o -> Just <$> f v o
963+accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)
964+accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o
965+accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)
966+accumMaybeMB f z e = do
967+ rec let e' = flip push e $ \o -> do
968+ v <- sample d'
969+ f v o
970+ d' <- hold z e'
971+ return d'
972+mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
973+mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o
974+mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
975+mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o
976+mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)
977+mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o
978+
979+{-# INLINABLE mapAccumMaybeMB #-}
980+mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)
981+mapAccumMaybeMB f z e = do
982+ rec let e' = flip push e $ \o -> do
983+ v <- sample d'
984+ result <- f v o
985+ return $ case result of
986+ (Nothing, Nothing) -> Nothing
987+ _ -> Just result
988+ d' <- hold z $ fmapMaybe fst e'
989+ return (d', fmapMaybe snd e')
990+
991+-- | Accumulate occurrences of an 'Event', producing an output occurrence each
992+-- time. Discard the underlying 'Accumulator'.
993+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)
994+mapAccum_ f z e = do
995+ (_, result) <- mapAccumB f z e
996+ return result
997+
998+-- | Accumulate occurrences of an 'Event', possibly producing an output
999+-- occurrence each time. Discard the underlying 'Accumulator'.
1000+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)
1001+mapAccumMaybe_ f z e = do
1002+ (_, result) <- mapAccumMaybeB f z e
1003+ return result
1004+
1005+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing
1006+-- an output occurrence each time. Discard the underlying 'Accumulator'.
1007+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)
1008+mapAccumM_ f z e = do
1009+ (_, result) <- mapAccumMB f z e
1010+ return result
1011+
1012+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly
1013+-- producing an output occurrence each time. Discard the underlying
1014+-- 'Accumulator'.
1015+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)
1016+mapAccumMaybeM_ f z e = do
1017+ (_, result) <- mapAccumMaybeMB f z e
1018+ return result
1019+
1020+instance Reflex t => Accumulator t (Dynamic t) where
1021+ accumMaybeM = accumMaybeMDyn
1022+ mapAccumMaybeM = mapAccumMaybeMDyn
1023+
1024+instance Reflex t => Accumulator t (Behavior t) where
1025+ accumMaybeM = accumMaybeMB
1026+ mapAccumMaybeM = mapAccumMaybeMB
1027+
1028+instance Reflex t => Accumulator t (Event t) where
1029+ accumMaybeM f z e = updated <$> accumMaybeM f z e
1030+ mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
1031+
1032+-- | Create a new 'Event' by combining each occurence with the next value of the
1033+-- list using the supplied function. If the list runs out of items, all
1034+-- subsequent 'Event' occurrences will be ignored.
1035+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
1036+zipListWithEvent f l e = do
1037+ let f' a b = case a of
1038+ h:t -> (Just t, Just $ f h b)
1039+ _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
1040+ mapAccumMaybe_ f' l e
1041+
1042+-- | Assign a number to each occurence of the given 'Event', starting from 0
1043+numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))
1044+numberOccurrences = numberOccurrencesFrom 0
1045+
1046+-- | Assign a number to each occurence of the given 'Event'
1047+numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))
1048+numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))
1049+
1050+-- | Assign a number to each occurence of the given 'Event'; discard the occurrences' values
1051+numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)
1052+numberOccurrencesFrom_ = mapAccum_ (\n _ -> (n + 1, n))
1053+
1054+-- | This is used to sample the value of a 'Behavior' using an 'Event'.
1055+--
1056+-- The '<@>' operator is intended to be used in conjunction with
1057+-- the 'Applicative' instance for 'Behavior'.
1058+--
1059+-- This is useful when we want to combine the values of one 'Event' and
1060+-- the value of several 'Behavior's at the time the 'Event' is firing.
1061+--
1062+-- If we have:
1063+--
1064+-- > f :: a -> b -> c -> d
1065+-- > b1 :: Behavior t a
1066+-- > b2 :: Behavior t b
1067+-- > e :: Event t c
1068+--
1069+-- then we can do:
1070+--
1071+-- > f <$> b1 <*> b2 <@> e :: Event t d
1072+--
1073+-- in order to apply the function 'f' to the relevant values.
1074+--
1075+-- The alternative would be something like:
1076+--
1077+-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d
1078+--
1079+-- or a variation involing a custom data type to hold the combination of
1080+-- 'Behavior's even when that combination might only ever be used by 'f'.
1081+--
1082+-- A more suggestive example might be:
1083+--
1084+-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)
1085+--
1086+(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b
1087+(<@>) b = push $ \x -> do
1088+ f <- sample b
1089+ return . Just . f $ x
1090+infixl 4 <@>
1091+
1092+-- | An version of '<@>' that does not use the value of the 'Event'.
1093+--
1094+-- Alternatively, it is 'tag' in operator form.
1095+--
1096+-- This is useful when we want to combine the values of several
1097+-- 'Behavior's at particular points in time using an 'Applicative'
1098+-- style syntax.
1099+--
1100+-- If we have:
1101+--
1102+-- > g :: a -> b -> d
1103+-- > b1 :: Behavior t a
1104+-- > b2 :: Behavior t b
1105+-- > e :: Event t c
1106+--
1107+-- where 'e' is firing at the points in time of interest.
1108+--
1109+-- Then we can use '<@':
1110+--
1111+-- > g <$> b1 <*> b2 <@ e :: Event t d
1112+--
1113+-- to combine the values of 'b1' and 'b2' at each of those points of time,
1114+-- with the function 'g' being used to combine the values.
1115+--
1116+-- This is the same as '<@>' except that the 'Event' is being used only
1117+-- to act as a trigger.
1118+(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b
1119+(<@) = tag
1120+infixl 4 <@
1121+
1122+-- | A 'Monad' that supports adjustment over time. After an action has been
1123+-- run, if the given events fire, it will adjust itself so that its net effect
1124+-- is as though it had originally been run with the new value. Note that there
1125+-- is some issue here with persistent side-effects: obviously, IO (and some
1126+-- other side-effects) cannot be undone, so it is up to the instance implementer
1127+-- to determine what the best meaning for this class is in such cases.
1128+class (Reflex t, Monad m) => MonadAdjust t m | m -> t where
1129+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
1130+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
1131+ 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'))
1132+ 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'))
1133+
1134+instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where
1135+ runWithReplace a0 a' = do
1136+ r <- ask
1137+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
1138+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
1139+ r <- ask
1140+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1141+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
1142+ r <- ask
1143+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1144+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
1145+ r <- ask
1146+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
1147+
1148+sequenceDMapWithAdjust :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
1149+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
1150+
1151+sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
1152+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
1153+
1154+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'))
1155+mapMapWithAdjustWithMove f m0 m' = do
1156+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
1157+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
1158+
1159+------------------
1160+-- Cheap Functions
1161+------------------
1162+
1163+{-# INLINE pushAlwaysCheap #-}
1164+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
1165+pushAlwaysCheap f = pushCheap (fmap Just . f)
1166+
1167+{-# INLINE fmapMaybeCheap #-}
1168+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1169+fmapMaybeCheap f = pushCheap $ return . f
1170+
1171+{-# INLINE fforMaybeCheap #-}
1172+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b
1173+fforMaybeCheap = flip fmapMaybeCheap
1174+
1175+{-# INLINE fforCheap #-}
1176+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b
1177+fforCheap = flip fmapCheap
1178+
1179+{-# INLINE fmapCheap #-}
1180+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b
1181+fmapCheap f = pushCheap $ return . Just . f
1182+
1183+{-# INLINE tagCheap #-}
1184+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1185+tagCheap b = pushAlwaysCheap $ \_ -> sample b
1186+
1187+{-# INLINE mergeWithCheap #-}
1188+mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1189+mergeWithCheap = mergeWithCheap' id
1190+
1191+{-# INLINE mergeWithCheap' #-}
1192+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
1193+mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f
1194+
1195+{-# INLINE mergeWithFoldCheap' #-}
1196+mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b
1197+mergeWithFoldCheap' f es =
1198+ fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)
1199+ . mergeInt
1200+ . IntMap.fromDistinctAscList
1201+ $ zip [0 :: Int ..] es
1202+
1203+--------------------------------------------------------------------------------
1204+-- Deprecated functions
1205+--------------------------------------------------------------------------------
1206+
1207+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's
1208+-- occurs. If both occur at the same time they are combined using 'mappend'.
1209+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}
1210+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
1211+appendEvents = alignWith $ mergeThese mappend
1212+
1213+-- | Alias for 'headE'
1214+{-# DEPRECATED onceE "Use 'headE' instead" #-}
1215+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
1216+onceE = headE
1217+
1218+-- | Run both sides of a 'These' monadically, combining the results.
1219+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
1220+#ifdef USE_TEMPLATE_HASKELL
1221+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}
1222+#endif
1223+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
1224+sequenceThese t = case t of
1225+ This ma -> fmap This ma
1226+ These ma mb -> liftM2 These ma mb
1227+ That mb -> fmap That mb
src/Reflex/Dynamic.hsnew file+687
@@ -0,0 +1,687 @@
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+ , eitherDyn
38+ , factorDyn
39+ , scanDyn
40+ , scanDynMaybe
41+ , holdUniqDyn
42+ , holdUniqDynBy
43+ , improvingMaybe
44+ , foldDyn
45+ , foldDynM
46+ , foldDynMaybe
47+ , foldDynMaybeM
48+ , joinDynThroughMap
49+ , traceDyn
50+ , traceDynWith
51+ , splitDynPure
52+ , distributeMapOverDynPure
53+ , distributeDMapOverDynPure
54+ , distributeListOverDynPure
55+ , Demux
56+ , demux
57+ , demuxed
58+ -- Things that probably aren't very useful:
59+ , HList (..)
60+ , FHList (..)
61+ , collectDynPure
62+ , RebuildSortedHList (..)
63+ , IsHList (..)
64+ , AllAreFunctors (..)
65+ , HListPtr (..)
66+ , distributeFHListOverDynPure
67+ -- Unsafe
68+ , unsafeDynamic
69+ -- * Deprecated functions
70+ , apDyn
71+ , attachDyn
72+ , attachDynWith
73+ , attachDynWithMaybe
74+ , collectDyn
75+ , combineDyn
76+ , distributeDMapOverDyn
77+ , distributeFHListOverDyn
78+ , forDyn
79+ , forDynM
80+ , getDemuxed
81+ , joinDyn
82+ , mapDyn
83+ , mapDynM
84+ , mconcatDyn
85+ , nubDyn
86+ , splitDyn
87+ , tagDyn
88+ , uniqDyn
89+ , uniqDynBy
90+ ) where
91+
92+import Data.Functor.Compose
93+import Data.Functor.Misc
94+import Reflex.Class
95+
96+import Control.Applicative ((<*>))
97+import Control.Monad
98+import Control.Monad.Fix
99+import Control.Monad.Identity
100+import Data.Align
101+import Data.Dependent.Map (DMap)
102+import qualified Data.Dependent.Map as DMap
103+import Data.Dependent.Sum (DSum (..))
104+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
105+import Data.Map (Map)
106+import Data.Maybe
107+import Data.Monoid
108+import Data.These
109+
110+import Debug.Trace
111+
112+-- | Create a new 'Dynamic' that only signals changes if the values actually
113+-- changed.
114+holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)
115+holdUniqDyn = holdUniqDynBy (==)
116+
117+-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'
118+-- changes and the given function returns 'False' when given both the old and
119+-- the new values.
120+holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)
121+holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)
122+
123+-- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing)
124+improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))
125+improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)
126+
127+-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'. This
128+-- function does not force its input 'Dynamic' until the output 'Dynamic' is
129+-- forced.
130+scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)
131+scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b)
132+
133+-- | Like 'scanDyn', but the the accumulator function may decline to update the
134+-- result 'Dynamic''s value.
135+scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)
136+scanDynMaybe z f d = do
137+ rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do
138+ b <- sample $ current d'
139+ return $ f a b
140+ return d'
141+
142+-- | Create a 'Dynamic' using the initial value and change it each time the
143+-- 'Event' occurs using a folding function on the previous value and the value
144+-- of the 'Event'.
145+foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
146+foldDyn = accumDyn . flip
147+
148+-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it
149+-- can 'sample' existing 'Behaviors' and 'hold' new ones.
150+foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
151+foldDynM = accumMDyn . flip
152+
153+-- | Create a 'Dynamic' using the provided initial value and change it each time
154+-- the provided 'Event' occurs, using a function to combine the old value with
155+-- the 'Event''s value. If the function returns 'Nothing', the value is not
156+-- changed; this is distinct from returning 'Just' the old value, since the
157+-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire
158+-- in the 'Nothing' case.
159+foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
160+foldDynMaybe = accumMaybeDyn . flip
161+
162+-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it
163+-- can 'sample' existing 'Behaviors' and 'hold' new ones.
164+foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
165+foldDynMaybeM = accumMaybeMDyn . flip
166+
167+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
168+count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
169+count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
170+
171+-- | Create a new 'Dynamic' using the initial value that flips its
172+-- value every time the 'Event' occurs.
173+toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
174+toggle = foldDyn (const not)
175+
176+-- | Switches to the new 'Event' whenever it receives one. Switching occurs
177+-- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the
178+-- old and new inner Events fire simultaneously, the output will fire with the
179+-- value of the *new* 'Event'.
180+switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
181+switchPromptlyDyn de =
182+ let eLag = switch $ current de
183+ eCoincidences = coincidence $ updated de
184+ in leftmost [eCoincidences, eLag]
185+
186+-- | Split a 'Dynamic' pair into a pair of 'Dynamic's
187+splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)
188+splitDynPure d = (fmap fst d, fmap snd d)
189+
190+-- | Convert a 'Map' with 'Dynamic' elements into a 'Dynamic' of a 'Map' with
191+-- non-'Dynamic' elements.
192+distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
193+distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
194+
195+-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
196+-- non-'Dynamic' elements, preserving the order of the elements.
197+distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]
198+distributeListOverDynPure =
199+ fmap (map fromDSum . DMap.toAscList) .
200+ distributeDMapOverDynPure .
201+ DMap.fromDistinctAscList .
202+ zipWith toDSum [0..]
203+ where
204+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)
205+ toDSum k v = Const2 k :=> v
206+ fromDSum :: DSum (Const2 Int a) Identity -> a
207+ fromDSum (Const2 _ :=> Identity v) = v
208+
209+--TODO: Generalize this to functors other than Maps
210+-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
211+-- with the current values of the 'Dynamic's in a map.
212+joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
213+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure
214+
215+-- | Print the value of the 'Dynamic' when it is first read and on each
216+-- subsequent change that is observed (as traceEvent), prefixed with the
217+-- provided string. This should /only/ be used for debugging.
218+--
219+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
220+-- else in the system is depending on it.
221+traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
222+traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
223+
224+-- | Print the result of applying the provided function to the value
225+-- of the 'Dynamic' when it is first read and on each subsequent change
226+-- that is observed (as traceEvent). This should /only/ be used for
227+-- debugging.
228+--
229+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
230+-- else in the system is depending on it.
231+traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
232+traceDynWith f d =
233+ let e' = traceEventWith f $ updated d
234+ getV0 = do
235+ x <- sample $ current d
236+ trace (f x) $ return x
237+ in unsafeBuildDynamic getV0 e'
238+
239+-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
240+-- each time the 'Event' occurs.
241+--
242+-- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing
243+-- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d`
244+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
245+-- will be used, since the 'Behavior' won't be updated until the end of the frame.
246+-- Additionally, this means that the output 'Event' may not be used to directly change
247+-- the input 'Dynamic', because that would mean its value depends on itself. When creating
248+-- cyclic data flows, generally `tag (current d) e` is preferred.
249+tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
250+tagPromptlyDyn = attachPromptlyDynWith const
251+
252+-- | Attach the current value of the 'Dynamic' to the value of the
253+-- 'Event' each time it occurs.
254+--
255+-- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details.
256+attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
257+attachPromptlyDyn = attachPromptlyDynWith (,)
258+
259+-- | Combine the current value of the 'Dynamic' with the value of the
260+-- 'Event' each time it occurs.
261+--
262+-- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details.
263+attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
264+attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b
265+
266+-- | Create a new 'Event' by combining the value at each occurence with the
267+-- current value of the 'Dynamic' value and possibly filtering if the combining
268+-- function returns 'Nothing'.
269+--
270+-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f
271+-- (current d)`. See 'tagPromptlyDyn' for details.
272+attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
273+attachPromptlyDynWithMaybe f d e =
274+ let e' = attach (current d) e
275+ in fforMaybe (align e' $ updated d) $ \case
276+ This (a, b) -> f a b -- Only the tagging event is firing, so use that
277+ These (_, b) a -> f a b -- Both events are firing, so use the newer value
278+ That _ -> Nothing -- The tagging event isn't firing, so don't fire
279+
280+-- | Factor a @Dynamic t (Maybe a)@ into a @Dynamic t (Maybe (Dynamic t a))@,
281+-- such that the outer 'Dynamic' is updated only when the 'Maybe''s constructor
282+-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor
283+-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track
284+-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the
285+-- existing inner 'Dynamic' will become constant, and will not change when the
286+-- outer constructor changes back to 'Nothing'.
287+maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))
288+maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack
289+ where pack = \case
290+ Nothing -> Left ()
291+ Just a -> Right a
292+ unpack = \case
293+ Left _ -> Nothing
294+ Right a -> Just a
295+
296+eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))
297+eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
298+ where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)
299+ unpack = \case
300+ LeftTag :=> Compose a -> Left $ coerceDynamic a
301+ RightTag :=> Compose b -> Right $ coerceDynamic b
302+
303+factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
304+factorDyn d = do
305+ let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a))
306+ inner k v0 = holdDyn v0 . fmapMaybe id =<< takeWhileE isJust newVal
307+ where newVal = ffor (updated d) $ \(newK :=> newV) -> case newK `geq` k of
308+ Just Refl -> Just newV
309+ Nothing -> Nothing
310+ getInitial = do
311+ k0 :=> (v0 :: v a) <- sample $ current d
312+ i0 <- inner k0 v0
313+ return $ k0 :=> Compose i0
314+ update = flip push (updated d) $ \(newKey :=> newVal) -> do
315+ (oldKey :=> _) <- sample $ current d
316+ case newKey `geq` oldKey of
317+ Just Refl -> return Nothing
318+ Nothing -> do
319+ newInner <- inner newKey newVal
320+ return $ Just $ newKey :=> Compose newInner
321+ o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic
322+ holdDyn o0 update
323+
324+--------------------------------------------------------------------------------
325+-- Demux
326+--------------------------------------------------------------------------------
327+
328+-- | Represents a time changing value together with an 'EventSelector' that can
329+-- efficiently detect when the underlying 'Dynamic' has a particular value.
330+-- This is useful for representing data like the current selection of a long
331+-- list.
332+--
333+-- Semantically,
334+--
335+-- > demuxed (demux d) k === fmap (== k) d
336+--
337+-- However, the when getDemuxed is used multiple times, the complexity is only
338+-- /O(log(n))/, rather than /O(n)/ for fmap.
339+data Demux t k = Demux { demuxValue :: Behavior t k
340+ , demuxSelector :: EventSelector t (Const2 k Bool)
341+ }
342+
343+-- | Demultiplex an input value to a 'Demux' with many outputs. At any given
344+-- time, whichever output is indicated by the given 'Dynamic' will be 'True'.
345+demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
346+demux k = Demux (current k)
347+ (fan $ attachWith (\k0 k1 -> if k0 == k1
348+ then DMap.empty
349+ else DMap.fromList [Const2 k0 :=> Identity False,
350+ Const2 k1 :=> Identity True])
351+ (current k) (updated k))
352+
353+-- | Select a particular output of the 'Demux'; this is equivalent to (but much
354+-- faster than) mapping over the original 'Dynamic' and checking whether it is
355+-- equal to the given key.
356+demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
357+demuxed d k =
358+ let e = select (demuxSelector d) (Const2 k)
359+ in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
360+
361+--------------------------------------------------------------------------------
362+-- collectDyn
363+--------------------------------------------------------------------------------
364+
365+--TODO: This whole section is badly in need of cleanup
366+
367+-- | A heterogeneous list whose type and length are fixed statically. This is
368+-- reproduced from the 'HList' package due to integration issues, and because
369+-- very little other functionality from that library is needed.
370+data HList (l::[*]) where
371+ HNil :: HList '[]
372+ HCons :: e -> HList l -> HList (e ': l)
373+
374+infixr 2 `HCons`
375+
376+type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
377+type instance HRevApp '[] l = l
378+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
379+
380+hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
381+hRevApp HNil l = l
382+hRevApp (HCons x l) l' = hRevApp l (HCons x l')
383+
384+hReverse :: HList l -> HList (HRevApp l '[])
385+hReverse l = hRevApp l HNil
386+
387+hBuild :: (HBuild' '[] r) => r
388+hBuild = hBuild' HNil
389+
390+class HBuild' l r where
391+ hBuild' :: HList l -> r
392+
393+instance (l' ~ HRevApp l '[])
394+ => HBuild' l (HList l') where
395+ hBuild' = hReverse
396+
397+instance HBuild' (a ': l) r
398+ => HBuild' l (a->r) where
399+ hBuild' l x = hBuild' (HCons x l)
400+
401+-- | Like 'HList', but with a functor wrapping each element.
402+data FHList f l where
403+ FHNil :: FHList f '[]
404+ FHCons :: f e -> FHList f l -> FHList f (e ': l)
405+
406+instance GEq (HListPtr l) where
407+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
408+ geqToEq _ = id
409+ geqUnify HHeadPtr HHeadPtr _ same = same
410+ geqUnify (HTailPtr a) (HTailPtr b) different same = geqUnify a b different same
411+ geqUnify _ _ different _ = different
412+#endif
413+ HHeadPtr `geq` HHeadPtr = Just Refl
414+ HHeadPtr `geq` HTailPtr _ = Nothing
415+ HTailPtr _ `geq` HHeadPtr = Nothing
416+ HTailPtr a `geq` HTailPtr b = a `geq` b
417+
418+instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
419+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
420+ gcompareToOrd _ = id
421+#endif
422+ HHeadPtr `gcompare` HHeadPtr = GEQ
423+ HHeadPtr `gcompare` HTailPtr _ = GLT
424+ HTailPtr _ `gcompare` HHeadPtr = GGT
425+ HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
426+
427+-- | A typed index into a typed heterogeneous list.
428+data HListPtr l a where
429+ HHeadPtr :: HListPtr (h ': t) h
430+ HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
431+
432+deriving instance Eq (HListPtr l a)
433+deriving instance Ord (HListPtr l a)
434+
435+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
436+fhlistToDMap = DMap.fromList . go
437+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
438+ go = \case
439+ FHNil -> []
440+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t)
441+
442+-- | This class allows 'HList's and 'FHlist's to be built from regular lists;
443+-- they must be contiguous and sorted.
444+class RebuildSortedHList l where
445+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
446+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
447+
448+instance RebuildSortedHList '[] where
449+ rebuildSortedFHList l = case l of
450+ [] -> FHNil
451+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
452+ rebuildSortedHList l = case l of
453+ [] -> HNil
454+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
455+
456+instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
457+ rebuildSortedFHList l = case l of
458+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
459+ _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
460+ rebuildSortedHList l = case l of
461+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
462+ _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
463+
464+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
465+dmapToHList = rebuildSortedHList . DMap.toList
466+
467+-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
468+-- single 'Dynamic' whose value represents the current values of all of the
469+-- input 'Dynamic's.
470+distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
471+distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
472+
473+-- | Indicates that all elements in a type-level list are applications of the
474+-- same functor.
475+class AllAreFunctors (f :: a -> *) (l :: [a]) where
476+ type FunctorList f l :: [*]
477+ toFHList :: HList (FunctorList f l) -> FHList f l
478+ fromFHList :: FHList f l -> HList (FunctorList f l)
479+
480+instance AllAreFunctors f '[] where
481+ type FunctorList f '[] = '[]
482+ toFHList l = case l of
483+ HNil -> FHNil
484+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
485+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
486+#endif
487+ fromFHList FHNil = HNil
488+
489+instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
490+ type FunctorList f (h ': t) = f h ': FunctorList f t
491+ toFHList l = case l of
492+ a `HCons` b -> a `FHCons` toFHList b
493+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
494+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
495+#endif
496+ fromFHList (a `FHCons` b) = a `HCons` fromFHList b
497+
498+-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
499+-- single 'Dynamic' whose value represents all the current values of the input's
500+-- consitutent 'Dynamic's.
501+collectDynPure :: ( RebuildSortedHList (HListElems b)
502+ , IsHList a, IsHList b
503+ , AllAreFunctors (Dynamic t) (HListElems b)
504+ , Reflex t
505+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
506+ ) => a -> Dynamic t b
507+collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds
508+
509+-- | Poor man's 'Generic's for product types only.
510+class IsHList a where
511+ type HListElems a :: [*]
512+ toHList :: a -> HList (HListElems a)
513+ fromHList :: HList (HListElems a) -> a
514+
515+instance IsHList (a, b) where
516+ type HListElems (a, b) = [a, b]
517+ toHList (a, b) = hBuild a b
518+ fromHList l = case l of
519+ a `HCons` b `HCons` HNil -> (a, b)
520+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
521+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
522+#endif
523+
524+instance IsHList (a, b, c, d) where
525+ type HListElems (a, b, c, d) = [a, b, c, d]
526+ toHList (a, b, c, d) = hBuild a b c d
527+ fromHList l = case l of
528+ a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
529+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
530+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
531+#endif
532+
533+instance IsHList (a, b, c, d, e, f) where
534+ type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
535+ toHList (a, b, c, d, e, f) = hBuild a b c d e f
536+ fromHList l = case l of
537+ a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
538+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
539+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
540+#endif
541+
542+--------------------------------------------------------------------------------
543+-- Deprecated functions
544+--------------------------------------------------------------------------------
545+
546+-- | Map a function over a 'Dynamic'.
547+{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}
548+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
549+mapDyn f = return . fmap f
550+
551+-- | 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.
552+{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-}
553+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)
554+mapDynM f d = do
555+ let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d
556+ eb' = fmap constant e'
557+ v0 = pull $ f =<< sample (current d)
558+ bb' :: Behavior t (Behavior t b) <- hold v0 eb'
559+ let b' = pull $ sample =<< sample bb'
560+ return $ unsafeDynamic b' e'
561+
562+-- | Flipped version of 'mapDyn'.
563+{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}
564+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
565+forDyn a = return . ffor a
566+
567+-- | Flipped version of 'mapDynM'
568+{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-}
569+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)
570+forDynM d f = mapDynM f d
571+
572+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value
573+-- of the tuple.
574+{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}
575+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
576+splitDyn = return . splitDynPure
577+
578+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
579+{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}
580+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
581+mconcatDyn = return . mconcat
582+
583+-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.
584+{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}
585+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
586+distributeDMapOverDyn = return . distributeDMapOverDynPure
587+
588+-- | Merge two 'Dynamic's into a new one using the provided function. The new
589+-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes
590+-- its value.
591+{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}
592+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
593+combineDyn f a b = return $ zipDynWith f a b
594+
595+-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
596+--
597+-- > do
598+-- > person <- Person `mapDyn` dynFirstName
599+-- > `apDyn` dynListName
600+-- > `apDyn` dynAge
601+-- > `apDyn` dynAddress
602+{-# 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" #-}
603+#ifdef USE_TEMPLATE_HASKELL
604+{-# ANN apDyn "HLint: ignore Use fmap" #-}
605+#endif
606+apDyn :: forall t m a b. (Reflex t, Monad m)
607+ => m (Dynamic t (a -> b))
608+ -> Dynamic t a
609+ -> m (Dynamic t b)
610+apDyn m a = fmap (<*> a) m
611+
612+--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
613+-- | This function no longer needs to be monadic, so it has been replaced by
614+-- 'demuxed', which is pure.
615+{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}
616+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
617+getDemuxed d = return . demuxed d
618+
619+-- | This function no longer needs to be monadic, so it has been replaced by
620+-- 'distributeFHListOverDynPure', which is pure.
621+{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}
622+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
623+distributeFHListOverDyn = return . distributeFHListOverDynPure
624+
625+-- | This function no longer needs to be monadic, so it has been replaced by
626+-- 'collectDynPure', which is pure.
627+{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}
628+collectDyn :: ( RebuildSortedHList (HListElems b)
629+ , IsHList a, IsHList b
630+ , AllAreFunctors (Dynamic t) (HListElems b)
631+ , Reflex t, Monad m
632+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
633+ ) => a -> m (Dynamic t b)
634+collectDyn = return . collectDynPure
635+
636+-- | This function has been renamed to 'tagPromptlyDyn' to clarify its
637+-- semantics.
638+{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}
639+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
640+tagDyn = tagPromptlyDyn
641+
642+-- | This function has been renamed to 'attachPromptlyDyn' to clarify its
643+-- semantics.
644+{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}
645+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
646+attachDyn = attachPromptlyDyn
647+
648+-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its
649+-- semantics.
650+{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}
651+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
652+attachDynWith = attachPromptlyDynWith
653+
654+-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify
655+-- its semantics.
656+{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}
657+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
658+attachDynWithMaybe = attachPromptlyDynWithMaybe
659+
660+-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s
661+-- current value will always be equal to the current value's current value, and
662+-- will change whenever either the inner or the outer (or both) values change.
663+{-# DEPRECATED joinDyn "Use 'join' instead" #-}
664+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a
665+joinDyn = join
666+
667+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
668+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
669+-- circumstances. Also, note that, unlike 'nub', this function does not prevent
670+-- all recurrences of a value, only consecutive recurrences.
671+{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
672+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
673+nubDyn = uniqDyn
674+
675+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
676+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
677+-- circumstances.
678+{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
679+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
680+uniqDyn = uniqDynBy (==)
681+
682+-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.
683+{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
684+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a
685+uniqDynBy eq d =
686+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)
687+ 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 <- accumMaybeMDyn f' z e
85+ return $ UniqDynamic d
86+ mapAccumMaybeM f z e = do
87+ let f' old change = do
88+ (mNew, output) <- f old change
89+ return (unsafeJustChanged old =<< mNew, output)
90+ (d, out) <- mapAccumMaybeMDyn f' z e
91+ return (UniqDynamic d, out)
92+
93+instance Reflex t => Functor (UniqDynamic t) where
94+ fmap f (UniqDynamic d) = uniqDynamic $ fmap f d
95+
96+instance Reflex t => Applicative (UniqDynamic t) where
97+ pure = UniqDynamic . constDyn
98+ UniqDynamic a <*> UniqDynamic b = uniqDynamic $ a <*> b
99+ _ *> b = b
100+ a <* _ = a
101+
102+instance Reflex t => Monad (UniqDynamic t) where
103+ UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f
104+ _ >> b = b
105+ return = pure
src/Reflex/DynamicWriter.hsnew file+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+269
@@ -0,0 +1,269 @@
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+ {-# INLINABLE hold #-}
132+ hold v0 = lift . hold v0
133+ {-# INLINABLE holdDyn #-}
134+ holdDyn v0 = lift . holdDyn v0
135+ {-# INLINABLE holdIncremental #-}
136+ holdIncremental v0 = lift . holdIncremental v0
137+ {-# INLINABLE buildDynamic #-}
138+ buildDynamic a0 = lift . buildDynamic a0
139+ {-# INLINABLE headE #-}
140+ headE = lift . headE
141+
142+instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
143+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
144+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
145+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
146+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
147+
148+instance Requester t m => Requester t (EventWriterT t w m) where
149+ type Request (EventWriterT t w m) = Request m
150+ type Response (EventWriterT t w m) = Response m
151+ requesting = lift . requesting
152+ requesting_ = lift . requesting_
153+
154+-- | Given a function like 'runWithReplace' for the underlying monad, implement
155+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
156+-- monad doesn't have a 'MonadAdjust' instance or to override the default
157+-- 'MonadAdjust' behavior.
158+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
159+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
160+ -> EventWriterT t w m a
161+ -> Event t (EventWriterT t w m b)
162+ -> EventWriterT t w m (a, Event t b)
163+runWithReplaceEventWriterTWith f a0 a' = do
164+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
165+ request <- holdDyn (snd result0) $ fmapCheap snd result'
166+ -- 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.)
167+ tellEvent $ coincidence $ updated request
168+ tellEvent $ switch $ current request
169+ return (fst result0, fmapCheap fst result')
170+
171+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
172+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))
173+ => ( (IntMap.Key -> v -> m (Event t w, v'))
174+ -> IntMap v
175+ -> Event t (p v)
176+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
177+ )
178+ -> (p (Event t w) -> [Event t w])
179+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
180+ -> (IntMap.Key -> v -> EventWriterT t w m v')
181+ -> IntMap v
182+ -> Event t (p v)
183+ -> EventWriterT t w m (IntMap v', Event t (p v'))
184+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
185+ let f' :: IntMap.Key -> v -> m (Event t w, v')
186+ f' k v = swap <$> runEventWriterT (f k v)
187+ (children0, children') <- base f' dm0 dm'
188+ let result0 = fmap snd children0
189+ result' = fmapCheap (fmap snd) children'
190+ requests0 :: IntMap (Event t w)
191+ requests0 = fmap fst children0
192+ requests' :: Event t (p (Event t w))
193+ requests' = fmapCheap (fmap fst) children'
194+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
195+ -- 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.)
196+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
197+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
198+ [] -> Nothing
199+ h : t -> Just $ sconcat $ h :| t
200+ return (result0, result')
201+
202+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
203+sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
204+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
205+ -> DMap k v
206+ -> Event t (p k v)
207+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
208+ )
209+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
210+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
211+ -> (p' (Some k) (Event t w) -> [Event t w])
212+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
213+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
214+ -> DMap k v
215+ -> Event t (p k v)
216+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
217+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
218+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
219+ f' k v = Compose . swap <$> runEventWriterT (f k v)
220+ (children0, children') <- base f' dm0 dm'
221+ let result0 = DMap.map (snd . getCompose) children0
222+ result' = fforCheap children' $ mapPatch $ snd . getCompose
223+ requests0 :: Map (Some k) (Event t w)
224+ requests0 = weakenDMapWith (fst . getCompose) children0
225+ requests' :: Event t (p' (Some k) (Event t w))
226+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
227+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
228+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
229+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
230+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
231+ [] -> Nothing
232+ h : t -> Just $ sconcat $ h :| t
233+ return (result0, result')
234+
235+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
236+ type Performable (EventWriterT t w m) = Performable m
237+ performEvent_ = lift . performEvent_
238+ performEvent = lift . performEvent
239+
240+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
241+ getPostBuild = lift getPostBuild
242+
243+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
244+ newTriggerEvent = lift newTriggerEvent
245+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
246+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
247+
248+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
249+ ask = lift ask
250+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
251+ reader = lift . reader
252+
253+instance MonadRef m => MonadRef (EventWriterT t w m) where
254+ type Ref (EventWriterT t w m) = Ref m
255+ newRef = lift . newRef
256+ readRef = lift . readRef
257+ writeRef r = lift . writeRef r
258+
259+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
260+ atomicModifyRef r = lift . atomicModifyRef r
261+
262+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
263+ newEventWithTrigger = lift . newEventWithTrigger
264+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
265+
266+instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
267+ tellQueryIncremental = lift . tellQueryIncremental
268+ askQueryResult = lift askQueryResult
269+ 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+56
@@ -0,0 +1,56 @@
1+-- | This module provides a GHC plugin designed to improve code that uses
2+-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level
3+-- definition that doesn't have an explicit inlining pragma. In the future,
4+-- additional optimizations are likely to be added.
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+module Reflex.Optimizer
9+ ( plugin
10+ ) where
11+
12+#ifdef ghcjs_HOST_OS
13+import Plugins
14+#else
15+import Control.Arrow
16+import CoreMonad
17+import Data.String
18+import GhcPlugins
19+#endif
20+
21+#ifdef ghcjs_HOST_OS
22+
23+-- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used.
24+plugin :: Plugin
25+plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS."
26+
27+#else
28+
29+-- | The GHC plugin itself. See "GhcPlugins" for more details.
30+plugin :: Plugin
31+plugin = defaultPlugin { installCoreToDos = install }
32+
33+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
34+install [] p = do
35+ liftIO $ putStrLn $ showSDocUnsafe $ ppr p
36+ let f = \case
37+ simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]
38+ x -> [x]
39+ return $ makeInlinable : concatMap f p
40+install options@(_:_) p = do
41+ warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"
42+ install [] p
43+
44+makeInlinable :: CoreToDo
45+makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do
46+ let f v = setIdInfo v $ let i = idInfo v in
47+ setInlinePragInfo i $ let p = inlinePragInfo i in
48+ if isDefaultInlinePragma p
49+ then defaultInlinePragma { inl_inline = Inlinable }
50+ else p
51+ newBinds = flip map (mg_binds modGuts) $ \case
52+ NonRec b e -> NonRec (f b) e
53+ Rec bes -> Rec $ map (first f) bes
54+ return $ modGuts { mg_binds = newBinds }
55+
56+#endif
src/Reflex/Patch.hsnew file+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+186
@@ -0,0 +1,186 @@
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 qualified Control.Monad.Trans.Control as TransControl
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 (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
58+ {-# INLINABLE getPostBuild #-}
59+ getPostBuild = PostBuildT ask
60+
61+instance MonadSample t m => MonadSample t (PostBuildT t m) where
62+ {-# INLINABLE sample #-}
63+ sample = lift . sample
64+
65+instance MonadHold t m => MonadHold t (PostBuildT t m) where
66+ {-# INLINABLE hold #-}
67+ hold v0 = lift . hold v0
68+ {-# INLINABLE holdDyn #-}
69+ holdDyn v0 = lift . holdDyn v0
70+ {-# INLINABLE holdIncremental #-}
71+ holdIncremental v0 = lift . holdIncremental v0
72+ {-# INLINABLE buildDynamic #-}
73+ buildDynamic a0 = lift . buildDynamic a0
74+ {-# INLINABLE headE #-}
75+ headE = lift . headE
76+
77+instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
78+ type Performable (PostBuildT t m) = Performable m
79+ {-# INLINABLE performEvent_ #-}
80+ performEvent_ = lift . performEvent_
81+ {-# INLINABLE performEvent #-}
82+ performEvent = lift . performEvent
83+
84+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
85+ {-# INLINABLE newEventWithTrigger #-}
86+ newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
87+ {-# INLINABLE newFanEventWithTrigger #-}
88+ newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
89+
90+instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
91+ {-# INLINABLE newTriggerEvent #-}
92+ newTriggerEvent = lift newTriggerEvent
93+ {-# INLINABLE newTriggerEventWithOnComplete #-}
94+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
95+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
96+
97+instance MonadRef m => MonadRef (PostBuildT t m) where
98+ type Ref (PostBuildT t m) = Ref m
99+ {-# INLINABLE newRef #-}
100+ newRef = lift . newRef
101+ {-# INLINABLE readRef #-}
102+ readRef = lift . readRef
103+ {-# INLINABLE writeRef #-}
104+ writeRef r = lift . writeRef r
105+
106+instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
107+ {-# INLINABLE atomicModifyRef #-}
108+ atomicModifyRef r = lift . atomicModifyRef r
109+
110+instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where
111+ runWithReplace a0 a' = do
112+ postBuild <- getPostBuild
113+ lift $ do
114+ rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
115+ let voidResult' = fmapCheap (\_ -> ()) result'
116+ return result
117+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
118+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
119+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
120+ traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
121+ traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
122+
123+{-# INLINABLE mapIntMapWithAdjustImpl #-}
124+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
125+ => ( (IntMap.Key -> (Event t (), v) -> m v')
126+ -> IntMap (Event t (), v)
127+ -> Event t (p (Event t (), v))
128+ -> m (IntMap v', Event t (p v'))
129+ )
130+ -> (IntMap.Key -> v -> PostBuildT t m v')
131+ -> IntMap v
132+ -> Event t (p v)
133+ -> PostBuildT t m (IntMap v', Event t (p v'))
134+mapIntMapWithAdjustImpl base f dm0 dm' = do
135+ postBuild <- getPostBuild
136+ let loweredDm0 = fmap ((,) postBuild) dm0
137+ f' :: IntMap.Key -> (Event t (), v) -> m v'
138+ f' k (e, v) = do
139+ runPostBuildT (f k v) e
140+ lift $ do
141+ rec (result0, result') <- base f' loweredDm0 loweredDm'
142+ cohortDone <- numberOccurrencesFrom_ 1 result'
143+ numberedDm' <- numberOccurrencesFrom 1 dm'
144+ let postBuild' = fanInt $ fmapCheap (\n -> IntMap.singleton n ()) cohortDone
145+ loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
146+ return $ fmap ((,) (selectInt postBuild' n)) p
147+ return (result0, result')
148+
149+{-# INLINABLE mapDMapWithAdjustImpl #-}
150+mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
151+ => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
152+ -> DMap k (Compose ((,) (Bool, Event t ())) v)
153+ -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
154+ -> m (DMap k v', Event t (p k v'))
155+ )
156+ -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
157+ -> (forall a. k a -> v a -> PostBuildT t m (v' a))
158+ -> DMap k v
159+ -> Event t (p k v)
160+ -> PostBuildT t m (DMap k v', Event t (p k v'))
161+mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
162+ postBuild <- getPostBuild
163+ let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
164+ f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
165+ f' k (Compose ((shouldHeadE, e), v)) = do
166+ eOnce <- if shouldHeadE
167+ 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
168+ else return e
169+ runPostBuildT (f k v) eOnce
170+ lift $ do
171+ rec (result0, result') <- base f' loweredDm0 loweredDm'
172+ let voidResult' = fmapCheap (\_ -> ()) result'
173+ let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
174+ return (result0, result')
175+
176+--------------------------------------------------------------------------------
177+-- Deprecated functionality
178+--------------------------------------------------------------------------------
179+
180+-- | Deprecated
181+instance TransControl.MonadTransControl (PostBuildT t) where
182+ type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
183+ {-# INLINABLE liftWith #-}
184+ liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
185+ {-# INLINABLE restoreT #-}
186+ restoreT = TransControl.defaultRestoreT PostBuildT
src/Reflex/PostBuild/Class.hsnew file+42
@@ -0,0 +1,42 @@
1+-- | This module defines 'PostBuild', which indicates that an action will be
2+-- notified when it, and any action it's a part of, has finished executing.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+#ifdef USE_REFLEX_OPTIMIZER
13+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
14+#endif
15+module Reflex.PostBuild.Class
16+ ( PostBuild (..)
17+ ) where
18+
19+import Reflex.Class
20+
21+import Control.Monad.Reader
22+import Control.Monad.State
23+import qualified Control.Monad.State.Strict as Strict
24+
25+-- | 'PostBuild' represents an action that is notified via an 'Event' when it
26+-- has finished executing. Note that the specific definition of "finished" is
27+-- determined by the instance of 'PostBuild', but the intent is to allow
28+-- 'Behavior's and 'Dynamic's to be safely sampled, regardless of where they
29+-- were created, when the post-build 'Event' fires. The post-build 'Event' will
30+-- fire exactly once for an given action.
31+class (Reflex t, Monad m) => PostBuild t m | m -> t where
32+ -- | Retrieve the post-build 'Event' for this action.
33+ getPostBuild :: m (Event t ())
34+
35+instance PostBuild t m => PostBuild t (ReaderT r m) where
36+ getPostBuild = lift getPostBuild
37+
38+instance PostBuild t m => PostBuild t (StateT s m) where
39+ getPostBuild = lift getPostBuild
40+
41+instance PostBuild t m => PostBuild t (Strict.StateT s m) where
42+ getPostBuild = lift getPostBuild
src/Reflex/Profiled.hsnew file+195
@@ -0,0 +1,195 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE InstanceSigs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+module Reflex.Profiled where
11+
12+import Control.Lens hiding (children)
13+import Control.Monad
14+import Control.Monad.Fix
15+import Control.Monad.Primitive
16+import Control.Monad.Reader
17+import Control.Monad.Ref
18+import Data.Coerce
19+import Data.Dependent.Map (DMap, GCompare)
20+import Data.List
21+import Data.FastMutableIntMap
22+import Data.IORef
23+import Data.Map (Map)
24+import qualified Data.Map.Strict as Map
25+import Data.Monoid
26+import Data.Type.Coercion
27+import Foreign.Ptr
28+import GHC.Foreign
29+import GHC.IO.Encoding
30+import GHC.Stack
31+import Reflex.Class
32+import Reflex.PerformEvent.Class
33+import Reflex.Host.Class
34+
35+import System.IO.Unsafe
36+import Unsafe.Coerce
37+
38+data ProfiledTimeline t
39+
40+{-# NOINLINE profilingData #-}
41+profilingData :: IORef (Map (Ptr CostCentreStack) Int)
42+profilingData = unsafePerformIO $ newIORef Map.empty
43+
44+data CostCentreTree = CostCentreTree
45+ { _costCentreTree_ownEntries :: !Int
46+ , _costCentreTree_cumulativeEntries :: !Int
47+ , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
48+ }
49+ deriving (Show, Eq, Ord)
50+
51+instance Monoid CostCentreTree where
52+ mempty = CostCentreTree 0 0 mempty
53+ CostCentreTree oa ea ca `mappend` CostCentreTree ob eb cb = CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (<>) ca cb
54+
55+getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
56+getCostCentreStack = go []
57+ where go l ccs = if ccs == nullPtr
58+ then return l
59+ else do
60+ cc <- ccsCC ccs
61+ parent <- ccsParent ccs
62+ go (cc : l) parent
63+
64+toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
65+toCostCentreTree ccs n = do
66+ ccList <- getCostCentreStack ccs
67+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
68+
69+printCostCentreTree :: CostCentreTree -> IO ()
70+printCostCentreTree = go 0
71+ where go depth cct = do
72+ let children = sortOn (_costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
73+ indent = mconcat $ replicate depth " "
74+ forM_ children $ \(cc, childCct) -> do
75+ lbl <- peekCString utf8 =<< ccLabel cc
76+ mdl <- peekCString utf8 =<< ccModule cc
77+ loc <- peekCString utf8 =<< ccSrcSpan cc
78+ let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
79+ putStrLn $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
80+ go (succ depth) childCct
81+
82+showProfilingData :: IO ()
83+showProfilingData = do
84+ vals <- readIORef profilingData
85+ cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
86+ printCostCentreTree cct
87+
88+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
89+
90+profileEvent :: Reflex t => Event t a -> Event t a
91+profileEvent e = unsafePerformIO $ do
92+ stack <- getCurrentCCS e
93+ let f x = unsafePerformIO $ do
94+ modifyIORef' profilingData $ Map.insertWith (+) stack 1
95+ return $ return $ Just x
96+ return $ pushCheap f e
97+
98+--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
99+
100+instance Reflex t => Reflex (ProfiledTimeline t) where
101+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
102+ newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
103+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
104+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
105+ type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
106+ type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
107+ never = Event_Profiled never
108+ constant = Behavior_Profiled . constant
109+ push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
110+ pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
111+ pull = Behavior_Profiled . pull . coerce
112+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
113+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
114+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
115+ switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
116+ coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
117+ current (Dynamic_Profiled d) = coerce $ current d
118+ updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
119+ unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
120+ unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
121+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
122+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
123+ currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
124+ updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
125+ incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
126+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
127+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
128+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
129+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
130+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
131+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
132+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
133+ fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
134+
135+deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
136+deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
137+deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
138+
139+instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
140+ hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
141+ holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
142+ holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
143+ buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
144+ headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
145+
146+instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
147+ sample (Behavior_Profiled b) = ProfiledM $ sample b
148+
149+instance MonadTrans ProfiledM where
150+ lift = ProfiledM
151+
152+instance MonadIO m => MonadIO (ProfiledM m) where
153+ liftIO = lift . liftIO
154+
155+instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
156+ type Performable (ProfiledM m) = Performable m
157+ performEvent_ = lift . performEvent_ . coerce
158+ performEvent = lift . fmap coerce . performEvent . coerce
159+
160+instance MonadRef m => MonadRef (ProfiledM m) where
161+ type Ref (ProfiledM m) = Ref m
162+ newRef = lift . newRef
163+ readRef = lift . readRef
164+ writeRef r = lift . writeRef r
165+
166+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
167+ newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
168+ newFanEventWithTrigger f = do
169+ es <- lift $ newFanEventWithTrigger f
170+ return $ EventSelector $ \k -> coerce $ select es k
171+
172+instance MonadReader r m => MonadReader r (ProfiledM m) where
173+ ask = lift ask
174+ local f (ProfiledM a) = ProfiledM $ local f a
175+ reader = lift . reader
176+
177+instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
178+ type EventTrigger (ProfiledTimeline t) = EventTrigger t
179+ type EventHandle (ProfiledTimeline t) = EventHandle t
180+ type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
181+
182+instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
183+ subscribeEvent = lift . subscribeEvent . coerce
184+
185+instance PrimMonad m => PrimMonad (ProfiledM m) where
186+ type PrimState (ProfiledM m) = PrimState m
187+ primitive = lift . primitive
188+
189+instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
190+ type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
191+ fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
192+ runHostFrame = lift . runHostFrame . coerce
193+
194+instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
195+ readEvent = lift . fmap coerce . readEvent
src/Reflex/Pure.hsnew file+204
@@ -0,0 +1,204 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE InstanceSigs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+#ifdef USE_REFLEX_OPTIMIZER
9+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10+#endif
11+
12+-- There are two expected orphan instances in this module:
13+-- * MonadSample (Pure t) ((->) t)
14+-- * MonadHold (Pure t) ((->) t)
15+{-# OPTIONS_GHC -fno-warn-orphans #-}
16+
17+-- | This module provides a pure implementation of Reflex, which is intended to
18+-- serve as a reference for the semantics of the Reflex class. All
19+-- implementations of Reflex should produce the same results as this
20+-- implementation, although performance and laziness/strictness may differ.
21+module Reflex.Pure
22+ ( Pure
23+ , Behavior (..)
24+ , Event (..)
25+ , Dynamic (..)
26+ , Incremental (..)
27+ ) where
28+
29+#if !MIN_VERSION_base(4,8,0)
30+import Control.Applicative
31+#endif
32+
33+import Control.Monad
34+import Data.Dependent.Map (DMap, GCompare)
35+import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Identity
37+import Data.IntMap (IntMap)
38+import qualified Data.IntMap as IntMap
39+import Data.Maybe
40+import Data.MemoTrie
41+import Data.Monoid
42+import Data.Type.Coercion
43+import Reflex.Class
44+
45+-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
46+-- with the type @t@.
47+data Pure t
48+
49+-- | The Enum instance of t must be dense: for all x :: t, there must not exist
50+-- any y :: t such that pred x < y < x. The HasTrie instance will be used
51+-- exclusively to memoize functions of t, not for any of its other capabilities.
52+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
53+
54+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
55+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
56+ newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
57+ newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
58+
59+ type PushM (Pure t) = (->) t
60+ type PullM (Pure t) = (->) t
61+
62+ never :: Event (Pure t) a
63+ never = Event $ \_ -> Nothing
64+
65+ constant :: a -> Behavior (Pure t) a
66+ constant x = Behavior $ \_ -> x
67+
68+ push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
69+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
70+
71+ pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
72+ pushCheap = push
73+
74+ pull :: PullM (Pure t) a -> Behavior (Pure t) a
75+ pull = Behavior . memo
76+
77+ -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
78+ -- warning because the GCompare instance is not used; however, removing the
79+ -- GCompare instance produces a different warning, due to that constraint
80+ -- being present in the original class definition
81+
82+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
83+ merge events = Event $ memo $ \t ->
84+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
85+ in if DMap.null currentOccurrences
86+ then Nothing
87+ else Just currentOccurrences
88+
89+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
90+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
91+
92+ switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
93+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
94+
95+ coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
96+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
97+
98+ current :: Dynamic (Pure t) a -> Behavior (Pure t) a
99+ current d = Behavior $ \t -> fst $ unDynamic d t
100+
101+ updated :: Dynamic (Pure t) a -> Event (Pure t) a
102+ updated d = Event $ \t -> snd $ unDynamic d t
103+
104+ unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
105+ unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
106+
107+ -- See UNUSED_CONSTRAINT, above.
108+
109+ --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
110+ --a) -> Incremental (Pure t) p a
111+ unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
112+
113+ mergeIncremental = mergeIncrementalImpl
114+ mergeIncrementalWithMove = mergeIncrementalImpl
115+
116+ currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
117+
118+ updatedIncremental i = Event $ \t -> snd $ unIncremental i t
119+
120+ incrementalToDynamic i = Dynamic $ \t ->
121+ let (old, mPatch) = unIncremental i t
122+ e = case mPatch of
123+ Nothing -> Nothing
124+ Just patch -> apply patch old
125+ in (old, e)
126+ behaviorCoercion Coercion = Coercion
127+ eventCoercion Coercion = Coercion
128+ dynamicCoercion Coercion = Coercion
129+
130+ fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
131+
132+ mergeIntIncremental = mergeIntIncrementalImpl
133+
134+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
135+mergeIncrementalImpl i = Event $ \t ->
136+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
137+ in if DMap.null results
138+ then Nothing
139+ else Just results
140+
141+mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
142+mergeIntIncrementalImpl i = Event $ \t ->
143+ let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
144+ in if IntMap.null results
145+ then Nothing
146+ else Just results
147+
148+instance Functor (Dynamic (Pure t)) where
149+ fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
150+ in (f cur, fmap f upd)
151+
152+instance Applicative (Dynamic (Pure t)) where
153+ pure a = Dynamic $ \_ -> (a, Nothing)
154+ (<*>) = ap
155+
156+instance Monad (Dynamic (Pure t)) where
157+ return = pure
158+ (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
159+ let (curX :: a, updX :: Maybe a) = unDynamic x t
160+ (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
161+ (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
162+ Nothing -> (Nothing, Nothing)
163+ Just nextX -> let (c, u) = unDynamic (f nextX) t
164+ in (Just c, u)
165+ in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
166+
167+instance MonadSample (Pure t) ((->) t) where
168+
169+ sample :: Behavior (Pure t) a -> (t -> a)
170+ sample = unBehavior
171+
172+instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
173+
174+ hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
175+ hold initialValue e initialTime = Behavior f
176+ where f = memo $ \sampleTime ->
177+ -- Really, the sampleTime should never be prior to the initialTime,
178+ -- because that would mean the Behavior is being sampled before
179+ -- being created.
180+ if sampleTime <= initialTime
181+ then initialValue
182+ else let lastTime = pred sampleTime
183+ in fromMaybe (f lastTime) $ unEvent e lastTime
184+
185+ holdDyn v0 = buildDynamic (return v0)
186+
187+ buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
188+ buildDynamic initialValue e initialTime =
189+ let Behavior f = hold (initialValue initialTime) e initialTime
190+ in Dynamic $ \t -> (f t, unEvent e t)
191+
192+ holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
193+ holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
194+ where f = memo $ \sampleTime ->
195+ -- Really, the sampleTime should never be prior to the initialTime,
196+ -- because that would mean the Behavior is being sampled before
197+ -- being created.
198+ if sampleTime <= initialTime
199+ then initialValue
200+ else let lastTime = pred sampleTime
201+ lastValue = f lastTime
202+ in case unEvent e lastTime of
203+ Nothing -> lastValue
204+ Just x -> fromMaybe lastValue $ apply x lastValue
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+419
@@ -0,0 +1,419 @@
1+-- | This module provides 'RequesterT', the standard implementation of
2+-- 'Requester'.
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE BangPatterns #-}
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE EmptyDataDecls #-}
7+{-# LANGUAGE ExistentialQuantification #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE GADTs #-}
10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11+{-# LANGUAGE MultiParamTypeClasses #-}
12+{-# LANGUAGE Rank2Types #-}
13+{-# LANGUAGE RecursiveDo #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE StandaloneDeriving #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE UndecidableInstances #-}
19+#ifdef USE_REFLEX_OPTIMIZER
20+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
21+#endif
22+module Reflex.Requester.Base
23+ ( RequesterT (..)
24+ , runRequesterT
25+ , runWithReplaceRequesterTWith
26+ , traverseIntMapWithKeyWithAdjustRequesterTWith
27+ , traverseDMapWithKeyWithAdjustRequesterTWith
28+ , RequesterData
29+ , RequesterDataKey
30+ , traverseRequesterData
31+ , requesterDataToList
32+ , singletonRequesterData
33+ ) where
34+
35+import Reflex.Class
36+import Reflex.Dynamic
37+import Reflex.Host.Class
38+import Reflex.PerformEvent.Class
39+import Reflex.PostBuild.Class
40+import Reflex.Requester.Class
41+import Reflex.TriggerEvent.Class
42+
43+import Control.Monad.Exception
44+import Control.Monad.Identity
45+import Control.Monad.Reader
46+import Control.Monad.Ref
47+import Control.Monad.State.Strict
48+import Data.Bits
49+import Data.Coerce
50+import Data.Dependent.Map (DMap, DSum (..))
51+import qualified Data.Dependent.Map as DMap
52+import qualified Data.Some as Some
53+import Data.FastMutableIntMap
54+import Data.Functor.Compose
55+import Data.Functor.Misc
56+import Data.IntMap.Strict (IntMap)
57+import qualified Data.IntMap.Strict as IntMap
58+import Data.Map (Map)
59+import qualified Data.Map as Map
60+import Data.Monoid ((<>))
61+import Data.Unique.Tag
62+import Data.Some (Some)
63+import Data.Type.Equality
64+import Data.Proxy
65+
66+import GHC.Exts (Any)
67+import Unsafe.Coerce
68+
69+--TODO: Make this module type-safe
70+
71+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
72+
73+newtype RequesterData f = RequesterData (TagMap (Entry f))
74+
75+data RequesterDataKey a where
76+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
77+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead
78+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
79+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
80+
81+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
82+singletonRequesterData rdk v = case rdk of
83+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
84+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
85+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
86+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
87+
88+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
89+requesterDataToList (RequesterData m) = do
90+ k :=> Entry e <- tagMapToList m
91+ case myKeyType k of
92+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
93+ MyTagType_Multi -> do
94+ (k', e') <- IntMap.toList e
95+ k'' :=> e'' <- requesterDataToList e'
96+ return $ RequesterDataKey_Multi k k' k'' :=> e''
97+ MyTagType_Multi2 -> do
98+ (k', e') <- Map.toList e
99+ (k'', e'') <- IntMap.toList e'
100+ k''' :=> e''' <- requesterDataToList e''
101+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
102+ MyTagType_Multi3 -> do
103+ (k', e') <- IntMap.toList e
104+ (k'', e'') <- IntMap.toList e'
105+ k''' :=> e''' <- requesterDataToList e''
106+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
107+
108+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
109+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
110+
111+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
112+tagMapToList (TagMap m) = fmap f $ IntMap.toList m
113+ where f :: (Int, Any) -> DSum MyTag f
114+ f (k, v) = MyTag k :=> ((unsafeCoerce :: Any -> f a) v)
115+
116+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
117+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
118+ where
119+ g :: Int -> Any -> t Any
120+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
121+
122+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
123+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
124+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
125+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
126+ go k (Entry request) = Entry <$> case myKeyType k of
127+ MyTagType_Single -> f request
128+ MyTagType_Multi -> traverse (traverseRequesterData f) request
129+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
130+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
131+
132+data MyTagType :: * -> * where
133+ MyTagType_Single :: MyTagType (Single a)
134+ MyTagType_Multi :: MyTagType Multi
135+ MyTagType_Multi2 :: MyTagType (Multi2 k)
136+ MyTagType_Multi3 :: MyTagType Multi3
137+
138+myKeyType :: MyTag x -> MyTagType x
139+myKeyType (MyTag k) = case k .&. 0x3 of
140+ 0x0 -> unsafeCoerce MyTagType_Single
141+ 0x1 -> unsafeCoerce MyTagType_Multi
142+ 0x2 -> unsafeCoerce MyTagType_Multi2
143+ 0x3 -> unsafeCoerce MyTagType_Multi3
144+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
145+
146+data Single a
147+data Multi
148+data Multi2 (k :: * -> *)
149+data Multi3
150+
151+class MyTagTypeOffset x where
152+ myTagTypeOffset :: proxy x -> Int
153+
154+instance MyTagTypeOffset (Single a) where
155+ myTagTypeOffset _ = 0x0
156+
157+instance MyTagTypeOffset Multi where
158+ myTagTypeOffset _ = 0x1
159+
160+instance MyTagTypeOffset (Multi2 k) where
161+ myTagTypeOffset _ = 0x2
162+
163+instance MyTagTypeOffset Multi3 where
164+ myTagTypeOffset _ = 0x3
165+
166+type family EntryContents request a where
167+ EntryContents request (Single a) = request a
168+ EntryContents request Multi = IntMap (RequesterData request)
169+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
170+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
171+
172+newtype Entry request x = Entry { unEntry :: EntryContents request x }
173+
174+{-# INLINE singleEntry #-}
175+singleEntry :: f a -> Entry f (Single a)
176+singleEntry = Entry
177+
178+{-# INLINE multiEntry #-}
179+multiEntry :: IntMap (RequesterData f) -> Entry f Multi
180+multiEntry = Entry
181+
182+{-# INLINE unMultiEntry #-}
183+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
184+unMultiEntry = unEntry
185+
186+-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes
187+-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another
188+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
189+
190+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
191+
192+{-# INLINE castMyTagWrap #-}
193+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
194+castMyTagWrap = coerce
195+
196+instance GEq MyTag where
197+ (MyTag a) `geq` (MyTag b) =
198+ if a == b
199+ then Just $ unsafeCoerce Refl
200+ else Nothing
201+
202+instance GCompare MyTag where
203+ (MyTag a) `gcompare` (MyTag b) =
204+ case a `compare` b of
205+ LT -> GLT
206+ EQ -> unsafeCoerce GEQ
207+ GT -> GGT
208+
209+instance GEq (MyTagWrap f) where
210+ (MyTagWrap a) `geq` (MyTagWrap b) =
211+ if a == b
212+ then Just $ unsafeCoerce Refl
213+ else Nothing
214+
215+instance GCompare (MyTagWrap f) where
216+ (MyTagWrap a) `gcompare` (MyTagWrap b) =
217+ case a `compare` b of
218+ LT -> GLT
219+ EQ -> unsafeCoerce GEQ
220+ GT -> GGT
221+
222+data RequesterState t (request :: * -> *) = RequesterState
223+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
224+ , _requesterState_requests :: ![(Int, Event t Any)]
225+ }
226+
227+-- | A basic implementation of 'Requester'.
228+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
229+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
230+-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
231+#if MIN_VERSION_base(4,9,1)
232+ , MonadAsyncException
233+#endif
234+ )
235+
236+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
237+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
238+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
239+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
240+
241+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
242+-- requests are made, and responses should be provided in the input 'Event'.
243+-- The 'Tag' keys will be used to return the responses to the same place the
244+-- requests were issued.
245+
246+runRequesterT :: (Reflex t, Monad m)
247+ => RequesterT t request response m a
248+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
249+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
250+runRequesterT (RequesterT a) responses = do
251+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
252+ coerceEvent responses
253+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
254+
255+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
256+ type Request (RequesterT t request response m) = request
257+ type Response (RequesterT t request response m) = response
258+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
259+ requesting_ = void . tagRequest . fmapCheap singleEntry
260+
261+{-# INLINE tagRequest #-}
262+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))
263+tagRequest req = do
264+ old <- RequesterT get
265+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
266+ t = MyTagWrap n
267+ RequesterT $ put $ RequesterState
268+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
269+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
270+ }
271+ return t
272+
273+{-# INLINE responseFromTag #-}
274+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
275+responseFromTag (MyTagWrap t) = do
276+ responses :: EventSelectorInt t Any <- RequesterT ask
277+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
278+
279+instance MonadTrans (RequesterT t request response) where
280+ lift = RequesterT . lift . lift
281+
282+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
283+ type Performable (RequesterT t request response m) = Performable m
284+ performEvent_ = lift . performEvent_
285+ performEvent = lift . performEvent
286+
287+instance MonadRef m => MonadRef (RequesterT t request response m) where
288+ type Ref (RequesterT t request response m) = Ref m
289+ newRef = lift . newRef
290+ readRef = lift . readRef
291+ writeRef r = lift . writeRef r
292+
293+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
294+ newEventWithTrigger = lift . newEventWithTrigger
295+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
296+
297+instance MonadReader r m => MonadReader r (RequesterT t request response m) where
298+ ask = lift ask
299+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
300+ reader = lift . reader
301+
302+instance (Reflex t, MonadAdjust t m, MonadHold t m, MonadFix m) => MonadAdjust t (RequesterT t request response m) where
303+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
304+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
305+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
306+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
307+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
308+
309+requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
310+requesting' = responseFromTag . castMyTagWrap <=< tagRequest
311+
312+{-# INLINABLE runWithReplaceRequesterTWith #-}
313+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
314+ , MonadFix m
315+ )
316+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
317+ -> RequesterT t request response m a
318+ -> Event t (RequesterT t request response m b)
319+ -> RequesterT t request response m (a, Event t b)
320+runWithReplaceRequesterTWith f a0 a' = do
321+ rec na' <- numberOccurrencesFrom 1 a'
322+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
323+ let responses' = fanInt responses
324+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
325+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
326+ return (result0, fmapCheap (fst . snd) v')
327+
328+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
329+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
330+ ( Reflex t
331+ , MonadHold t m
332+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
333+ , Patch (p (Event t (IntMap (RequesterData request))))
334+ , Functor p
335+ , MonadFix m
336+ )
337+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
338+ -> IntMap (IntMap.Key, v)
339+ -> Event t (p (IntMap.Key, v))
340+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
341+ )
342+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
343+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
344+ -> (IntMap.Key -> v -> RequesterT t request response m v')
345+ -> IntMap v
346+ -> Event t (p v)
347+ -> RequesterT t request response m (IntMap v', Event t (p v'))
348+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
349+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
350+ let responses :: EventSelectorInt t (IntMap (RequesterData response))
351+ responses = fanInt $ fmapCheap unpack response
352+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
353+ unpack = unEntry
354+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
355+ pack = Entry
356+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
357+ f' k (n, v) = do
358+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?
359+ return (fmapCheap (IntMap.singleton n) myRequests, result)
360+ ndm' <- numberOccurrencesFrom 1 dm'
361+ (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to MonadAdjust
362+ let result0 = fmap snd children0
363+ result' = fforCheap children' $ fmap snd
364+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))
365+ requests0 = fmap fst children0
366+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))
367+ requests' = fforCheap children' $ fmap fst
368+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
369+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
370+ requests <- holdIncremental requests0 requests'
371+ return (result0, result')
372+
373+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
374+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
375+ ( GCompare k
376+ , Reflex t
377+ , MonadHold t m
378+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
379+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
380+ , MonadFix m
381+ )
382+ => (forall k' v1 v2. GCompare k'
383+ => (forall a. k' a -> v1 a -> m (v2 a))
384+ -> DMap k' v1
385+ -> Event t (p k' v1)
386+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
387+ )
388+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
389+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
390+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
391+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
392+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
393+ -> DMap k v
394+ -> Event t (p k v)
395+ -> RequesterT t request response m (DMap k v', Event t (p k v'))
396+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
397+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
398+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
399+ responses = fanMap $ fmapCheap unpack response
400+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
401+ unpack = unEntry
402+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
403+ pack = Entry
404+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
405+ f' k (Compose (n, v)) = do
406+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
407+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
408+ ndm' <- numberOccurrencesFrom 1 dm'
409+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
410+ let result0 = DMap.map (snd . getCompose) children0
411+ result' = fforCheap children' $ mapPatch $ snd . getCompose
412+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
413+ requests0 = weakenDMapWith (fst . getCompose) children0
414+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
415+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
416+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
417+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
418+ requests <- holdIncremental requests0 requests'
419+ 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+2471
@@ -0,0 +1,2471 @@
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+-- | A subscriber that never triggers other 'Event's
258+{-# INLINE terminalSubscriber #-}
259+terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a
260+terminalSubscriber p = Subscriber
261+ { subscriberPropagate = p
262+ , subscriberInvalidateHeight = \_ -> return ()
263+ , subscriberRecalculateHeight = \_ -> return ()
264+ }
265+
266+-- | Subscribe to an Event only for the duration of one occurrence
267+{-# INLINE subscribeAndReadHead #-}
268+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
269+subscribeAndReadHead e sub = do
270+ subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
271+ (subscription, occ) <- subscribeAndRead e $ sub
272+ { subscriberPropagate = \a -> do
273+ liftIO $ unsubscribe =<< readIORef subscriptionRef
274+ subscriberPropagate sub a
275+ }
276+ liftIO $ case occ of
277+ Nothing -> writeIORef subscriptionRef $! subscription
278+ Just _ -> unsubscribe subscription
279+ return (subscription, occ)
280+
281+--TODO: Make this lazy in its input event
282+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
283+headE originalE = do
284+ parent <- liftIO $ newIORef $ Just originalE
285+ defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
286+ let clearParent = liftIO $ writeIORef parent Nothing
287+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
288+ when (isJust occ) clearParent
289+ return $ Event $ \sub -> do
290+ liftIO (readIORef parent) >>= \case
291+ Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
292+ Just e -> subscribeAndReadHead e sub
293+
294+data CacheSubscribed x a
295+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
296+ , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
297+ , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
298+ }
299+
300+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
301+-- repeatedly
302+--
303+--TODO: Try a caching strategy where we subscribe directly to the parent when
304+--there's only one subscriber, and then build our own FastWeakBag only when a second
305+--subscriber joins
306+{-# NOINLINE [0] cacheEvent #-}
307+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
308+cacheEvent e =
309+#ifdef DEBUG_TRACE_EVENTS
310+ withStackOneLine $ \callSite -> Event $
311+#else
312+ Event $
313+#endif
314+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
315+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
316+ in \sub -> {-# SCC "cacheEvent" #-} do
317+#ifdef DEBUG_TRACE_EVENTS
318+ unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
319+#endif
320+ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
321+ Just subscribedTicket -> return subscribedTicket
322+ Nothing -> do
323+ subscribers <- liftIO FastWeakBag.empty
324+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
325+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
326+ { subscriberPropagate = \a -> do
327+ liftIO $ writeIORef occRef $ Just a
328+ scheduleClear occRef
329+ propagateFast a subscribers
330+ , subscriberInvalidateHeight = \old -> do
331+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
332+ , subscriberRecalculateHeight = \new -> do
333+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
334+ }
335+ when (isJust occ) $ do
336+ liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
337+ scheduleClear occRef
338+ let !subscribed = CacheSubscribed
339+ { _cacheSubscribed_subscribers = subscribers
340+ , _cacheSubscribed_parent = parentSub
341+ , _cacheSubscribed_occurrence = occRef
342+ }
343+ subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
344+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
345+ return subscribedTicket
346+ liftIO $ do
347+ subscribed <- getFastWeakTicketValue subscribedTicket
348+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
349+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
350+ let es = EventSubscription
351+ { _eventSubscription_unsubscribe = do
352+ FastWeakBag.remove ticket
353+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
354+ when isEmpty $ do
355+ writeIORef mSubscribedRef emptyFastWeak
356+ unsubscribe $ _cacheSubscribed_parent subscribed
357+ touch ticket
358+ touch subscribedTicket
359+ , _eventSubscription_subscribed = EventSubscribed
360+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
361+ , eventSubscribedRetained = toAny subscribedTicket
362+ }
363+ }
364+ return (es, occ)
365+
366+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
367+subscribe e s = fst <$> subscribeAndRead e s
368+
369+{-# INLINE wrap #-}
370+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
371+wrap tag getSpecificSubscribed sub = do
372+ (sln, subd, occ) <- getSpecificSubscribed sub
373+ let es = tag subd
374+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
375+
376+eventRoot :: GCompare k => k a -> Root x k -> Event x a
377+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
378+
379+eventNever :: Event x a
380+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
381+
382+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
383+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
384+
385+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
386+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
387+
388+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
389+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
390+
391+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
392+eventHold !h = Event $ subscribeHoldEvent h
393+
394+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
395+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
396+
397+{-# INLINE subscribeCoincidenceInner #-}
398+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)
399+subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
400+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
401+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
402+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
403+ let height = max innerHeight outerHeight
404+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
405+ return (innerOcc, height, innerSubd)
406+
407+--------------------------------------------------------------------------------
408+-- Subscriber
409+--------------------------------------------------------------------------------
410+
411+data Subscriber x a = Subscriber
412+ { subscriberPropagate :: !(a -> EventM x ())
413+ , subscriberInvalidateHeight :: !(Height -> IO ())
414+ , subscriberRecalculateHeight :: !(Height -> IO ())
415+ }
416+
417+--TODO: Move this comment to WeakBag
418+-- These function are constructor functions that are marked NOINLINE so they are
419+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
420+-- so any weak references that are attached to the constructors will have their
421+-- finalizer run. Using the opaque constructor, does not see the
422+-- constructor application, so it behaves like an IORef and cannot be fused away.
423+--
424+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
425+-- the weak pointer to it in some cases.
426+
427+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
428+newSubscriberHold h = return $ Subscriber
429+ { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
430+ , subscriberInvalidateHeight = \_ -> return ()
431+ , subscriberRecalculateHeight = \_ -> return ()
432+ }
433+
434+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
435+newSubscriberFan subscribed = return $ Subscriber
436+ { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
437+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
438+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
439+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
440+ scheduleClear $ fanSubscribedOccurrence subscribed
441+ let f _ (Pair (Identity v) subsubs) = do
442+ propagate v $ _fanSubscribedChildren_list subsubs
443+ return $ Constant ()
444+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
445+ return ()
446+ , subscriberInvalidateHeight = \old -> do
447+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
448+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
449+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
450+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
451+ , subscriberRecalculateHeight = \new -> do
452+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
453+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
454+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
455+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
456+ }
457+
458+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
459+newSubscriberSwitch subscribed = return $ Subscriber
460+ { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
461+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
462+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
463+ scheduleClear $ switchSubscribedOccurrence subscribed
464+ propagate a $ switchSubscribedSubscribers subscribed
465+ , subscriberInvalidateHeight = \_ -> do
466+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
467+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
468+ when (oldHeight /= invalidHeight) $ do
469+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
470+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
471+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
472+ , subscriberRecalculateHeight = \new -> do
473+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
474+ updateSwitchHeight new subscribed
475+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
476+ }
477+
478+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
479+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
480+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
481+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
482+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
483+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
484+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
485+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
486+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
487+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
488+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
489+ case occ of
490+ Nothing -> do
491+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
492+ writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
493+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
494+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
495+ Just o -> do -- Since it's already firing, no need to adjust height
496+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
497+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
498+ propagate o $ coincidenceSubscribedSubscribers subscribed
499+ , subscriberInvalidateHeight = \_ -> do
500+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
501+ invalidateCoincidenceHeight subscribed
502+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
503+ , subscriberRecalculateHeight = \_ -> do
504+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
505+ recalculateCoincidenceHeight subscribed
506+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
507+ }
508+
509+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
510+newSubscriberCoincidenceInner subscribed = return $ Subscriber
511+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
512+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
513+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
514+ case occ of
515+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
516+ Nothing -> do
517+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
518+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
519+ propagate a $ coincidenceSubscribedSubscribers subscribed
520+ , subscriberInvalidateHeight = \_ -> do
521+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
522+ invalidateCoincidenceHeight subscribed
523+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
524+ , subscriberRecalculateHeight = \_ -> do
525+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
526+ recalculateCoincidenceHeight subscribed
527+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
528+ }
529+
530+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
531+invalidateSubscriberHeight = flip subscriberInvalidateHeight
532+
533+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
534+recalculateSubscriberHeight = flip subscriberRecalculateHeight
535+
536+-- | Propagate everything at the current height
537+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
538+propagate a subscribers = withIncreasedDepth $ do
539+ -- 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
540+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
541+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
542+
543+-- | Propagate everything at the current height
544+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
545+propagateFast a subscribers = withIncreasedDepth $ do
546+ -- 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
547+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
548+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
549+
550+--------------------------------------------------------------------------------
551+-- EventSubscribed
552+--------------------------------------------------------------------------------
553+
554+toAny :: a -> Any
555+toAny = unsafeCoerce
556+
557+data EventSubscribed x = EventSubscribed
558+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
559+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
560+#ifdef DEBUG_CYCLES
561+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
562+ , eventSubscribedHasOwnHeightRef :: !Bool
563+ , eventSubscribedWhoCreated :: !(IO [String])
564+#endif
565+ }
566+
567+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
568+eventSubscribedRoot !r = EventSubscribed
569+ { eventSubscribedHeightRef = zeroRef
570+ , eventSubscribedRetained = toAny r
571+#ifdef DEBUG_CYCLES
572+ , eventSubscribedGetParents = return []
573+ , eventSubscribedHasOwnHeightRef = False
574+ , eventSubscribedWhoCreated = return ["root"]
575+#endif
576+ }
577+
578+eventSubscribedNever :: EventSubscribed x
579+eventSubscribedNever = EventSubscribed
580+ { eventSubscribedHeightRef = zeroRef
581+ , eventSubscribedRetained = toAny ()
582+#ifdef DEBUG_CYCLES
583+ , eventSubscribedGetParents = return []
584+ , eventSubscribedHasOwnHeightRef = False
585+ , eventSubscribedWhoCreated = return ["never"]
586+#endif
587+ }
588+
589+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
590+eventSubscribedFan !subscribed = EventSubscribed
591+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
592+ , eventSubscribedRetained = toAny subscribed
593+#ifdef DEBUG_CYCLES
594+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
595+ , eventSubscribedHasOwnHeightRef = False
596+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
597+#endif
598+ }
599+
600+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
601+eventSubscribedSwitch !subscribed = EventSubscribed
602+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
603+ , eventSubscribedRetained = toAny subscribed
604+#ifdef DEBUG_CYCLES
605+ , eventSubscribedGetParents = do
606+ s <- readIORef $ switchSubscribedCurrentParent subscribed
607+ return [Some.This $ _eventSubscription_subscribed s]
608+ , eventSubscribedHasOwnHeightRef = True
609+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
610+#endif
611+ }
612+
613+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
614+eventSubscribedCoincidence !subscribed = EventSubscribed
615+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
616+ , eventSubscribedRetained = toAny subscribed
617+#ifdef DEBUG_CYCLES
618+ , eventSubscribedGetParents = do
619+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
620+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
621+ innerParents = maybeToList $ fmap Some.This innerSubscription
622+ return $ outerParent : innerParents
623+ , eventSubscribedHasOwnHeightRef = True
624+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
625+#endif
626+ }
627+
628+getEventSubscribedHeight :: EventSubscribed x -> IO Height
629+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
630+
631+#ifdef DEBUG_CYCLES
632+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
633+whoCreatedEventSubscribed = eventSubscribedWhoCreated
634+
635+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
636+walkInvalidHeightParents s0 = do
637+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
638+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
639+ when (h == invalidHeight) $ do
640+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
641+ modify (Some.This s :)
642+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
643+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
644+ return subscribers
645+#endif
646+
647+{-# INLINE subscribeHoldEvent #-}
648+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
649+subscribeHoldEvent = subscribeAndRead . holdEvent
650+
651+--------------------------------------------------------------------------------
652+-- Behavior
653+--------------------------------------------------------------------------------
654+
655+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
656+
657+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
658+behaviorHold !h = Behavior $ readHoldTracked h
659+
660+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
661+behaviorHoldIdentity = behaviorHold
662+
663+behaviorConst :: a -> Behavior x a
664+behaviorConst !a = Behavior $ return a
665+
666+behaviorPull :: Pull x a -> Behavior x a
667+behaviorPull !p = Behavior $ do
668+ val <- liftIO $ readIORef $ pullValue p
669+ case val of
670+ Just subscribed -> do
671+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
672+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
673+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
674+ return $ pullSubscribedValue subscribed
675+ Nothing -> do
676+ i <- liftIO $ newInvalidatorPull p
677+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
678+ parentsRef <- liftIO $ newIORef []
679+ holdInits <- askBehaviorHoldInits
680+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
681+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
682+ parents <- liftIO $ readIORef parentsRef
683+ let subscribed = PullSubscribed
684+ { pullSubscribedValue = a
685+ , pullSubscribedInvalidators = invsRef
686+ , pullSubscribedOwnInvalidator = i
687+ , pullSubscribedParents = parents
688+ }
689+ liftIO $ writeIORef (pullValue p) $ Just subscribed
690+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
691+ return a
692+
693+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
694+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
695+
696+{-# INLINE readHoldTracked #-}
697+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
698+readHoldTracked h = do
699+ result <- liftIO $ readIORef $ holdValue h
700+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
701+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
702+ return result
703+
704+{-# INLINABLE readBehaviorUntracked #-}
705+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
706+readBehaviorUntracked b = do
707+ holdInits <- getDeferralQueue
708+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
709+
710+--------------------------------------------------------------------------------
711+-- Dynamic
712+--------------------------------------------------------------------------------
713+
714+data Dynamic x p = Dynamic
715+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
716+ , dynamicUpdated :: !(Event x p)
717+ }
718+
719+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
720+dynamicHold !h = Dynamic
721+ { dynamicCurrent = behaviorHold h
722+ , dynamicUpdated = eventHold h
723+ }
724+
725+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
726+dynamicHoldIdentity = dynamicHold
727+
728+dynamicConst :: PatchTarget p -> Dynamic x p
729+dynamicConst !a = Dynamic
730+ { dynamicCurrent = behaviorConst a
731+ , dynamicUpdated = eventNever
732+ }
733+
734+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
735+dynamicDyn !d = Dynamic
736+ { dynamicCurrent = behaviorDyn d
737+ , dynamicUpdated = eventDyn d
738+ }
739+
740+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
741+dynamicDynIdentity = dynamicDyn
742+
743+--------------------------------------------------------------------------------
744+-- Combinators
745+--------------------------------------------------------------------------------
746+
747+--TODO: Figure out why certain things are not 'representational', then make them
748+--representational so we can use coerce
749+
750+--type role Hold representational
751+data Hold x p
752+ = Hold { holdValue :: !(IORef (PatchTarget p))
753+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
754+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
755+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
756+#ifdef DEBUG_NODEIDS
757+ , holdNodeId :: Int
758+#endif
759+ }
760+
761+-- | A statically allocated 'SpiderTimeline'; this is the only instance of
762+-- 'SpiderTimeline' that can used when using
763+-- -fspecialize-to-spidertimeline-global.
764+data Global
765+
766+{-# NOINLINE globalSpiderTimelineEnv #-}
767+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
768+globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
769+
770+-- | Stores all global data relevant to a particular Spider timeline; only one
771+-- value should exist for each type @x@
772+data SpiderTimelineEnv x = SpiderTimelineEnv
773+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
774+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
775+#ifdef DEBUG
776+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
777+#endif
778+ }
779+type role SpiderTimelineEnv nominal
780+
781+instance Eq (SpiderTimelineEnv x) where
782+ _ == _ = True -- Since only one exists of each type
783+
784+instance GEq SpiderTimelineEnv where
785+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
786+ geqToEq _ = id
787+ geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b
788+ then case unsafeCoerce Refl :: a :~: b of
789+ Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
790+ else different
791+#else
792+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
793+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
794+ else Nothing
795+#endif
796+
797+data EventEnv x
798+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
799+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
800+ , eventEnvDynInits :: !(IORef [SomeDynInit x])
801+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
802+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
803+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
804+ , eventEnvIntClears :: !(IORef [SomeIntClear])
805+ , eventEnvRootClears :: !(IORef [SomeRootClear])
806+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
807+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
808+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
809+ }
810+
811+{-# INLINE runEventM #-}
812+runEventM :: EventM x a -> IO a
813+runEventM = unEventM
814+
815+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
816+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
817+
818+class MonadIO m => Defer a m where
819+ getDeferralQueue :: m (IORef [a])
820+
821+{-# INLINE defer #-}
822+defer :: Defer a m => a -> m ()
823+defer a = do
824+ q <- getDeferralQueue
825+ liftIO $ modifyIORef' q (a:)
826+
827+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
828+ {-# INLINE getDeferralQueue #-}
829+ getDeferralQueue = asksEventEnv eventEnvAssignments
830+
831+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
832+ {-# INLINE getDeferralQueue #-}
833+ getDeferralQueue = asksEventEnv eventEnvHoldInits
834+
835+instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
836+ {-# INLINE getDeferralQueue #-}
837+ getDeferralQueue = asksEventEnv eventEnvDynInits
838+
839+instance Defer (SomeHoldInit x) (BehaviorM x) where
840+ {-# INLINE getDeferralQueue #-}
841+ getDeferralQueue = BehaviorM $ asks snd
842+
843+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
844+ {-# INLINE getDeferralQueue #-}
845+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
846+
847+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
848+ {-# INLINE getDeferralQueue #-}
849+ getDeferralQueue = asksEventEnv eventEnvMergeInits
850+
851+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
852+ getCurrentHeight :: m Height
853+ scheduleMerge :: Height -> EventM x () -> m ()
854+
855+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
856+ {-# INLINE getCurrentHeight #-}
857+ getCurrentHeight = do
858+ heightRef <- asksEventEnv eventEnvCurrentHeight
859+ liftIO $ readIORef heightRef
860+ {-# INLINE scheduleMerge #-}
861+ scheduleMerge height subscribed = do
862+ delayedRef <- asksEventEnv eventEnvDelayedMerges
863+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
864+
865+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
866+class x ~ Global => HasSpiderTimeline x where
867+#else
868+class HasSpiderTimeline x where
869+#endif
870+ -- | Retrieve the current SpiderTimelineEnv
871+ spiderTimeline :: SpiderTimelineEnv x
872+
873+instance HasSpiderTimeline Global where
874+ spiderTimeline = globalSpiderTimelineEnv
875+
876+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
877+putCurrentHeight h = do
878+ heightRef <- asksEventEnv eventEnvCurrentHeight
879+ liftIO $ writeIORef heightRef $! h
880+
881+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
882+ {-# INLINE getDeferralQueue #-}
883+ getDeferralQueue = asksEventEnv eventEnvClears
884+
885+{-# INLINE scheduleClear #-}
886+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
887+scheduleClear r = defer $ SomeClear r
888+
889+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
890+ {-# INLINE getDeferralQueue #-}
891+ getDeferralQueue = asksEventEnv eventEnvIntClears
892+
893+{-# INLINE scheduleIntClear #-}
894+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
895+scheduleIntClear r = defer $ SomeIntClear r
896+
897+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
898+ {-# INLINE getDeferralQueue #-}
899+ getDeferralQueue = asksEventEnv eventEnvRootClears
900+
901+{-# INLINE scheduleRootClear #-}
902+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
903+scheduleRootClear r = defer $ SomeRootClear r
904+
905+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
906+ {-# INLINE getDeferralQueue #-}
907+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
908+
909+-- Note: hold cannot examine its event until after the phase is over
910+{-# INLINE [1] hold #-}
911+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
912+hold v0 e = do
913+ valRef <- liftIO $ newIORef v0
914+ invsRef <- liftIO $ newIORef []
915+ parentRef <- liftIO $ newIORef Nothing
916+#ifdef DEBUG_NODEIDS
917+ nodeId <- liftIO newNodeId
918+#endif
919+ let h = Hold
920+ { holdValue = valRef
921+ , holdInvalidators = invsRef
922+ , holdEvent = e
923+ , holdParent = parentRef
924+#ifdef DEBUG_NODEIDS
925+ , holdNodeId = nodeId
926+#endif
927+ }
928+ defer $ SomeHoldInit h
929+ return h
930+
931+{-# INLINE getHoldEventSubscription #-}
932+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)
933+getHoldEventSubscription h = do
934+ ep <- liftIO $ readIORef $ holdParent h
935+ case ep of
936+ Just subd -> return subd
937+ Nothing -> do
938+ let e = holdEvent h
939+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
940+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
941+ liftIO $ writeIORef subscriptionRef $! subscription
942+ case occ of
943+ Nothing -> return ()
944+ Just o -> do
945+ old <- liftIO $ readIORef $ holdValue h
946+ case apply o old of
947+ Nothing -> return ()
948+ Just new -> do
949+ -- Need to evaluate these so that we don't retain the Hold itself
950+ v <- liftIO $ evaluate $ holdValue h
951+ i <- liftIO $ evaluate $ holdInvalidators h
952+ defer $ SomeAssignment v i new
953+ liftIO $ writeIORef (holdParent h) $ Just subscription
954+ return subscription
955+
956+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
957+
958+--type role BehaviorM representational
959+-- BehaviorM can sample behaviors
960+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
961+
962+instance Monad (BehaviorM x) where
963+ {-# INLINE (>>=) #-}
964+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
965+ {-# INLINE (>>) #-}
966+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
967+ {-# INLINE return #-}
968+ return x = BehaviorM $ return x
969+ {-# INLINE fail #-}
970+ fail s = BehaviorM $ fail s
971+
972+data BehaviorSubscribed x a
973+ = forall p. BehaviorSubscribedHold (Hold x p)
974+ | BehaviorSubscribedPull (PullSubscribed x a)
975+
976+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
977+
978+--type role PullSubscribed representational
979+data PullSubscribed x a
980+ = PullSubscribed { pullSubscribedValue :: !a
981+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
982+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
983+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
984+ }
985+
986+--type role Pull representational
987+data Pull x a
988+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
989+ , pullCompute :: !(BehaviorM x a)
990+#ifdef DEBUG_NODEIDS
991+ , pullNodeId :: Int
992+#endif
993+ }
994+
995+data Invalidator x
996+ = forall a. InvalidatorPull (Pull x a)
997+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
998+
999+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1000+ { rootSubscribedKey :: !(k a)
1001+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
1002+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1003+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
1004+ , rootSubscribedUninit :: IO ()
1005+ , 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?
1006+#ifdef DEBUG_NODEIDS
1007+ , rootSubscribedNodeId :: Int
1008+#endif
1009+ }
1010+
1011+data Root x (k :: * -> *)
1012+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1013+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1014+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1015+ }
1016+
1017+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
1018+
1019+data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
1020+
1021+data SomeMergeUpdate x = SomeMergeUpdate
1022+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1023+ , _someMergeUpdate_invalidateHeight :: !(IO ())
1024+ , _someMergeUpdate_recalculateHeight :: !(IO ())
1025+ }
1026+
1027+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1028+
1029+-- EventM can do everything BehaviorM can, plus create holds
1030+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
1031+
1032+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1033+
1034+data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1035+ { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1036+ , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1037+ }
1038+
1039+data HeightBag = HeightBag
1040+ { _heightBag_size :: {-# UNPACK #-} !Int
1041+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1042+ }
1043+ deriving (Show, Read, Eq, Ord)
1044+
1045+heightBagEmpty :: HeightBag
1046+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1047+
1048+heightBagSize :: HeightBag -> Int
1049+heightBagSize = _heightBag_size
1050+
1051+heightBagFromList :: [Height] -> HeightBag
1052+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1053+
1054+heightBagAdd :: Height -> HeightBag -> HeightBag
1055+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1056+
1057+heightBagRemove :: Height -> HeightBag -> HeightBag
1058+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1059+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1060+ Just old -> HeightBag (pred s) $ case old of
1061+ 0 -> IntMap.delete h c
1062+ _ -> IntMap.insert h (pred old) c
1063+
1064+heightBagMax :: HeightBag -> Height
1065+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1066+ Just ((h, _), _) -> Height h
1067+ Nothing -> zeroHeight
1068+
1069+heightBagVerify :: HeightBag -> HeightBag
1070+#ifdef DEBUG
1071+heightBagVerify b@(HeightBag s c) = if
1072+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1073+ -> error $ "heightBagVerify: size doesn't match: " <> show b
1074+ | unHeight invalidHeight `IntMap.member` c
1075+ -> error $ "heightBagVerify: contains invalid height: " <> show b
1076+ | otherwise -> b
1077+#else
1078+heightBagVerify = id
1079+#endif
1080+
1081+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1082+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1083+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1084+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1085+ }
1086+
1087+data FanSubscribed (x :: *) k
1088+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1089+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1090+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1091+ , fanSubscribedParent :: !(EventSubscription x)
1092+#ifdef DEBUG_NODEIDS
1093+ , fanSubscribedNodeId :: Int
1094+#endif
1095+ }
1096+
1097+data Fan x k
1098+ = Fan { fanParent :: !(Event x (DMap k Identity))
1099+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1100+ }
1101+
1102+data SwitchSubscribed x a
1103+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1104+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
1105+ , switchSubscribedHeight :: !(IORef Height)
1106+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1107+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1108+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1109+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1110+ , switchSubscribedParent :: !(Behavior x (Event x a))
1111+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1112+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1113+#ifdef DEBUG_NODEIDS
1114+ , switchSubscribedNodeId :: Int
1115+#endif
1116+ }
1117+
1118+data Switch x a
1119+ = Switch { switchParent :: !(Behavior x (Event x a))
1120+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1121+ }
1122+
1123+#ifdef USE_TEMPLATE_HASKELL
1124+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1125+#endif
1126+data CoincidenceSubscribed x a
1127+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1128+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1129+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1130+ , coincidenceSubscribedHeight :: !(IORef Height)
1131+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1132+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1133+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1134+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1135+#ifdef DEBUG_NODEIDS
1136+ , coincidenceSubscribedNodeId :: Int
1137+#endif
1138+ }
1139+
1140+data Coincidence x a
1141+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1142+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1143+ }
1144+
1145+{-# NOINLINE newInvalidatorSwitch #-}
1146+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1147+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1148+
1149+{-# NOINLINE newInvalidatorPull #-}
1150+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1151+newInvalidatorPull p = return $! InvalidatorPull p
1152+
1153+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1154+ fmapMaybe f = push $ return . f
1155+
1156+instance HasSpiderTimeline x => Align (Event x) where
1157+ nil = eventNever
1158+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1159+
1160+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1161+
1162+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1163+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1164+
1165+--TODO: Avoid the duplication between this and R.zipDynWith
1166+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1167+zipDynWith f da db =
1168+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
1169+ ec = flip push eab $ \o -> do
1170+ (a, b) <- case o of
1171+ This (Identity a) -> do
1172+ b <- readBehaviorUntracked $ dynamicCurrent db
1173+ return (a, b)
1174+ That (Identity b) -> do
1175+ a <- readBehaviorUntracked $ dynamicCurrent da
1176+ return (a, b)
1177+ These (Identity a) (Identity b) -> return (a, b)
1178+ return $ Just $ Identity $ f a b
1179+ in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1180+
1181+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1182+buildDynamic readV0 v' = do
1183+ result <- liftIO $ newIORef $ Left (readV0, v')
1184+ let !d = Dyn result
1185+ defer $ SomeDynInit d
1186+ return d
1187+
1188+unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1189+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1190+ where x = (readV0, v')
1191+
1192+-- ResultM can read behaviors and events
1193+type ResultM = EventM
1194+
1195+{-# NOINLINE unsafeNewIORef #-}
1196+unsafeNewIORef :: a -> b -> IORef b
1197+unsafeNewIORef a b = unsafePerformIO $ do
1198+ touch a
1199+ newIORef b
1200+
1201+instance HasSpiderTimeline x => Functor (Event x) where
1202+ fmap f = push $ return . Just . f
1203+
1204+instance Functor (Behavior x) where
1205+ fmap f = pull . fmap f . readBehaviorTracked
1206+
1207+{-# INLINE push #-}
1208+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1209+push f e = cacheEvent (pushCheap f e)
1210+
1211+{-# INLINABLE pull #-}
1212+pull :: BehaviorM x a -> Behavior x a
1213+pull a = behaviorPull $ Pull
1214+ { pullCompute = a
1215+ , pullValue = unsafeNewIORef a Nothing
1216+#ifdef DEBUG_NODEIDS
1217+ , pullNodeId = unsafeNodeId a
1218+#endif
1219+ }
1220+
1221+{-# INLINABLE switch #-}
1222+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1223+switch a = eventSwitch $ Switch
1224+ { switchParent = a
1225+ , switchSubscribed = unsafeNewIORef a Nothing
1226+ }
1227+
1228+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1229+coincidence a = eventCoincidence $ Coincidence
1230+ { coincidenceParent = a
1231+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1232+ }
1233+
1234+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1235+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1236+run roots after = do
1237+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1238+ t <- SpiderHost ask
1239+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1240+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1241+ occBefore <- liftIO $ do
1242+ occBefore <- readIORef occRef
1243+ writeIORef occRef $! DMap.insert k a occBefore
1244+ return occBefore
1245+ if DMap.null occBefore
1246+ then do scheduleRootClear occRef
1247+ return $ Just r
1248+ else return Nothing
1249+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1250+ propagate a subscribersRef
1251+ delayedRef <- asksEventEnv eventEnvDelayedMerges
1252+ let go = do
1253+ delayed <- liftIO $ readIORef delayedRef
1254+ case IntMap.minViewWithKey delayed of
1255+ Nothing -> return ()
1256+ Just ((currentHeight, cur), future) -> do
1257+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1258+ putCurrentHeight $ Height currentHeight
1259+ liftIO $ writeIORef delayedRef $! future
1260+ sequence_ cur
1261+ go
1262+ go
1263+ putCurrentHeight maxBound
1264+ after
1265+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1266+ return result
1267+
1268+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1269+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1270+ height <- liftIO $ readIORef heightRef
1271+ currentHeight <- getCurrentHeight
1272+ case height `compare` currentHeight of
1273+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1274+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1275+ EQ -> a
1276+
1277+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1278+
1279+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1280+
1281+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1282+
1283+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1284+
1285+debugFinalize :: Bool
1286+debugFinalize = False
1287+
1288+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1289+mkWeakPtrWithDebug x debugNote = do
1290+ x' <- evaluate x
1291+ mkWeakPtr x' $
1292+ if debugFinalize
1293+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1294+ else Nothing
1295+
1296+type WeakList a = [Weak a]
1297+
1298+{-# INLINE withIncreasedDepth #-}
1299+#ifdef DEBUG
1300+withIncreasedDepth :: CanTrace x m => m a -> m a
1301+withIncreasedDepth a = do
1302+ spiderTimeline <- askSpiderTimelineEnv
1303+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1304+ result <- a
1305+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1306+ return result
1307+#else
1308+withIncreasedDepth :: m a -> m a
1309+withIncreasedDepth = id
1310+#endif
1311+
1312+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1313+
1314+{-# INLINE tracePropagate #-}
1315+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1316+tracePropagate p = traceWhen p debugPropagate
1317+
1318+{-# INLINE traceInvalidate #-}
1319+traceInvalidate :: String -> IO ()
1320+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1321+
1322+{-# INLINE traceWhen #-}
1323+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1324+traceWhen p b message = traceMWhen p b $ return message
1325+
1326+{-# INLINE traceMWhen #-}
1327+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1328+traceMWhen _ b getMessage = when b $ do
1329+ message <- getMessage
1330+#ifdef DEBUG
1331+ spiderTimeline <- askSpiderTimelineEnv
1332+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1333+#else
1334+ let d = 0
1335+#endif
1336+ liftIO $ putStrLn $ replicate d ' ' <> message
1337+
1338+whoCreatedIORef :: IORef a -> IO [String]
1339+whoCreatedIORef (IORef a) = whoCreated $! a
1340+
1341+#ifdef DEBUG_CYCLES
1342+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1343+groupByHead = \case
1344+ [] -> []
1345+ (x :| xs) : t -> case groupByHead t of
1346+ [] -> [(x, xs :| [])]
1347+ l@((y, yss) : t')
1348+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1349+ | otherwise -> (x, xs :| []) : l
1350+
1351+listsToForest :: Eq a => [[a]] -> Forest a
1352+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1353+#endif
1354+
1355+{-# INLINE propagateSubscriberHold #-}
1356+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1357+propagateSubscriberHold h a = do
1358+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1359+ invalidators <- liftIO $ readIORef $ holdInvalidators h
1360+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1361+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1362+ case {-# SCC "apply" #-} apply a v of
1363+ Nothing -> return ()
1364+ Just v' -> do
1365+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1366+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1367+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1368+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1369+
1370+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1371+
1372+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1373+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1374+
1375+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1376+askInvalidator = do
1377+ (!m, _) <- BehaviorM ask
1378+ case m of
1379+ Nothing -> return Nothing
1380+ Just (!wi, _) -> return $ Just wi
1381+
1382+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1383+askParentsRef = do
1384+ (!m, _) <- BehaviorM ask
1385+ case m of
1386+ Nothing -> return Nothing
1387+ Just (_, !p) -> return $ Just p
1388+
1389+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1390+askBehaviorHoldInits = do
1391+ (_, !his) <- BehaviorM ask
1392+ return his
1393+
1394+{-# INLINE getDynHold #-}
1395+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1396+getDynHold d = do
1397+ mh <- liftIO $ readIORef $ unDyn d
1398+ case mh of
1399+ Right h -> return h
1400+ Left (readV0, v') -> do
1401+ holdInits <- getDeferralQueue
1402+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1403+ h <- hold v0 v'
1404+ liftIO $ writeIORef (unDyn d) $ Right h
1405+ return h
1406+
1407+-- Always refers to 0
1408+{-# NOINLINE zeroRef #-}
1409+zeroRef :: IORef Height
1410+zeroRef = unsafePerformIO $ newIORef zeroHeight
1411+
1412+type CanSubscribe x m =
1413+ ( HasSpiderTimeline x
1414+ , HasCurrentHeight x m
1415+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state
1416+ , Defer SomeClear m -- Wiping out event firings
1417+ , Defer SomeIntClear m
1418+ , Defer (SomeAssignment x) m -- Updating state
1419+ , Defer (SomeResetCoincidence x) m
1420+ , m ~ EventM x
1421+ )
1422+
1423+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1424+getRootSubscribed k r sub = do
1425+ mSubscribed <- readIORef $ rootSubscribed r
1426+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1427+ case DMap.lookup k mSubscribed of
1428+ Just subscribed -> {-# SCC "hitRoot" #-} do
1429+ sln <- subscribeRootSubscribed subscribed sub
1430+ occ <- getOcc
1431+ return (sln, subscribed, occ)
1432+ Nothing -> {-# SCC "missRoot" #-} do
1433+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1434+ let !cached = rootSubscribed r
1435+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1436+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1437+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1438+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1439+ writeIORef uninitRef $! uninit
1440+ let !subscribed = RootSubscribed
1441+ { rootSubscribedKey = k
1442+ , rootSubscribedCachedSubscribed = cached
1443+ , rootSubscribedOccurrence = getOcc
1444+ , rootSubscribedSubscribers = subs
1445+ , rootSubscribedUninit = uninit
1446+ , rootSubscribedWeakSelf = weakSelf
1447+#ifdef DEBUG_NODEIDS
1448+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1449+#endif
1450+ }
1451+ -- If we die at the same moment that all our children die, they will
1452+ -- try to clean us up but will fail because their Weak reference to us
1453+ -- will also be dead. So, if we are dying, check if there are any
1454+ -- children; since children don't bother cleaning themselves up if
1455+ -- their parents are already dead, I don't think there's a race
1456+ -- condition here. However, if there are any children, then we can
1457+ -- infer that we need to clean ourselves up, so we do.
1458+ finalCleanup = do
1459+ cs <- readIORef $ _weakBag_children subs
1460+ when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1461+ writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1462+ 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
1463+ occ <- getOcc
1464+ return (sln, subscribed, occ)
1465+
1466+#ifdef USE_TEMPLATE_HASKELL
1467+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1468+#endif
1469+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1470+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1471+ rootSubscribedUninit self
1472+ modifyIORef' cached $ DMap.delete k
1473+
1474+{-# INLINE subscribeRootSubscribed #-}
1475+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1476+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1477+
1478+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1479+
1480+data FanInt x a = FanInt
1481+ { _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
1482+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1483+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1484+ }
1485+
1486+newFanInt :: IO (FanInt x a)
1487+newFanInt = do
1488+ 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
1489+ subscriptionRef <- newIORef $ error "fanInt: no subscription"
1490+ occRef <- newIORef $ error "fanInt: no occurrence"
1491+ return $ FanInt
1492+ { _fanInt_subscribers = subscribers
1493+ , _fanInt_subscriptionRef = subscriptionRef
1494+ , _fanInt_occRef = occRef
1495+ }
1496+
1497+{-# NOINLINE unsafeNewFanInt #-}
1498+unsafeNewFanInt :: b -> FanInt x a
1499+unsafeNewFanInt b = unsafePerformIO $ do
1500+ touch b
1501+ newFanInt
1502+
1503+{-# NOINLINE fanInt #-}
1504+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1505+fanInt p =
1506+ let self = unsafeNewFanInt p
1507+ in EventSelectorInt $ \k -> Event $ \sub -> do
1508+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1509+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1510+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1511+ { subscriberPropagate = \m -> do
1512+ liftIO $ writeIORef (_fanInt_occRef self) m
1513+ scheduleIntClear $ _fanInt_occRef self
1514+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do
1515+ FastWeakBag.traverse b $ \s -> do
1516+ subscriberPropagate s v
1517+ , subscriberInvalidateHeight = \old -> do
1518+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1519+ FastWeakBag.traverse b $ \s -> do
1520+ subscriberInvalidateHeight s old
1521+ , subscriberRecalculateHeight = \new -> do
1522+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1523+ FastWeakBag.traverse b $ \s -> do
1524+ subscriberRecalculateHeight s new
1525+ }
1526+ liftIO $ do
1527+ writeIORef (_fanInt_subscriptionRef self) subscription
1528+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1529+ scheduleIntClear $ _fanInt_occRef self
1530+ liftIO $ do
1531+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1532+ Nothing -> do
1533+ b <- FastWeakBag.empty
1534+ FastMutableIntMap.insert (_fanInt_subscribers self) k b
1535+ return b
1536+ Just b -> return b
1537+ t <- liftIO $ FastWeakBag.insert sub b
1538+ currentOcc <- readIORef (_fanInt_occRef self)
1539+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1540+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1541+
1542+{-# INLINABLE getFanSubscribed #-}
1543+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)
1544+getFanSubscribed k f sub = do
1545+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1546+ case mSubscribed of
1547+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1548+ sln <- subscribeFanSubscribed k subscribed sub
1549+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1550+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1551+ Nothing -> {-# SCC "missFan" #-} do
1552+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1553+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1554+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1555+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1556+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1557+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1558+ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1559+ occRef <- liftIO $ newIORef parentOcc
1560+ when (isJust parentOcc) $ scheduleClear occRef
1561+ let subscribed = FanSubscribed
1562+ { fanSubscribedCachedSubscribed = fanSubscribed f
1563+ , fanSubscribedOccurrence = occRef
1564+ , fanSubscribedParent = subscription
1565+ , fanSubscribedSubscribers = subscribersRef
1566+#ifdef DEBUG_NODEIDS
1567+ , fanSubscribedNodeId = unsafeNodeId f
1568+#endif
1569+ }
1570+ let !self = (k, subscribed)
1571+ liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1572+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1573+ liftIO $ writeIORef subscribedRef $! subscribed
1574+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1575+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1576+
1577+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1578+cleanupFanSubscribed (k, subscribed) = do
1579+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1580+ let reducedSubscribers = DMap.delete k subscribers
1581+ if DMap.null reducedSubscribers
1582+ then do
1583+ unsubscribe $ fanSubscribedParent subscribed
1584+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1585+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1586+ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1587+
1588+{-# INLINE subscribeFanSubscribed #-}
1589+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1590+subscribeFanSubscribed k subscribed sub = do
1591+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1592+ case DMap.lookup k subscribers of
1593+ Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1594+ let !self = (k, subscribed)
1595+ weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1596+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1597+ 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
1598+ return sln
1599+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1600+
1601+{-# INLINABLE getSwitchSubscribed #-}
1602+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)
1603+getSwitchSubscribed s sub = do
1604+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1605+ case mSubscribed of
1606+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1607+ sln <- subscribeSwitchSubscribed subscribed sub
1608+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1609+ return (sln, subscribed, occ)
1610+ Nothing -> {-# SCC "missSwitch" #-} do
1611+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1612+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1613+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1614+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1615+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1616+ wiRef <- liftIO $ newIORef wi
1617+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1618+ holdInits <- getDeferralQueue
1619+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1620+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1621+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1622+ subscriptionRef <- liftIO $ newIORef subscription
1623+ occRef <- liftIO $ newIORef parentOcc
1624+ when (isJust parentOcc) $ scheduleClear occRef
1625+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1626+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1627+ let !subscribed = SwitchSubscribed
1628+ { switchSubscribedCachedSubscribed = switchSubscribed s
1629+ , switchSubscribedOccurrence = occRef
1630+ , switchSubscribedHeight = heightRef
1631+ , switchSubscribedSubscribers = subs
1632+ , switchSubscribedOwnInvalidator = i
1633+ , switchSubscribedOwnWeakInvalidator = wiRef
1634+ , switchSubscribedBehaviorParents = parentsRef
1635+ , switchSubscribedParent = switchParent s
1636+ , switchSubscribedCurrentParent = subscriptionRef
1637+ , switchSubscribedWeakSelf = weakSelf
1638+#ifdef DEBUG_NODEIDS
1639+ , switchSubscribedNodeId = unsafeNodeId s
1640+#endif
1641+ }
1642+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1643+ liftIO $ writeIORef subscribedRef $! subscribed
1644+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1645+ return (slnForSub, subscribed, parentOcc)
1646+
1647+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1648+cleanupSwitchSubscribed subscribed = do
1649+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1650+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1651+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1652+
1653+{-# INLINE subscribeSwitchSubscribed #-}
1654+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1655+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1656+
1657+{-# INLINABLE getCoincidenceSubscribed #-}
1658+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)
1659+getCoincidenceSubscribed c sub = do
1660+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1661+ case mSubscribed of
1662+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1663+ sln <- subscribeCoincidenceSubscribed subscribed sub
1664+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1665+ return (sln, subscribed, occ)
1666+ Nothing -> {-# SCC "missCoincidence" #-} do
1667+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1668+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1669+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1670+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1671+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1672+ (occ, height, mInnerSubd) <- case outerOcc of
1673+ Nothing -> return (Nothing, outerHeight, Nothing)
1674+ Just o -> do
1675+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1676+ return (occ, height, Just innerSubd)
1677+ occRef <- liftIO $ newIORef occ
1678+ when (isJust occ) $ scheduleClear occRef
1679+ heightRef <- liftIO $ newIORef height
1680+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1681+ scheduleClear innerSubdRef
1682+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1683+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1684+ let subscribed = CoincidenceSubscribed
1685+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1686+ , coincidenceSubscribedOccurrence = occRef
1687+ , coincidenceSubscribedHeight = heightRef
1688+ , coincidenceSubscribedSubscribers = subs
1689+ , coincidenceSubscribedOuter = subOuter
1690+ , coincidenceSubscribedOuterParent = outerSubscription
1691+ , coincidenceSubscribedInnerParent = innerSubdRef
1692+ , coincidenceSubscribedWeakSelf = weakSelf
1693+#ifdef DEBUG_NODEIDS
1694+ , coincidenceSubscribedNodeId = unsafeNodeId c
1695+#endif
1696+ }
1697+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1698+ liftIO $ writeIORef subscribedRef $! subscribed
1699+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1700+ return (slnForSub, subscribed, occ)
1701+
1702+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1703+cleanupCoincidenceSubscribed subscribed = do
1704+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1705+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1706+
1707+{-# INLINE subscribeCoincidenceSubscribed #-}
1708+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1709+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1710+
1711+{-# INLINE merge #-}
1712+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1713+merge d = cacheEvent (mergeCheap d)
1714+
1715+{-# INLINE mergeWithMove #-}
1716+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1717+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1718+
1719+{-# INLINE [1] mergeCheap #-}
1720+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1721+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1722+ where
1723+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1724+ updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1725+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1726+ (mOldSubd, newPs) <- case me of
1727+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1728+ Just e -> do
1729+ let s = subscriber $ return k
1730+ subscription@(EventSubscription _ subd) <- subscribe e s
1731+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1732+ let newParent = MergeSubscribedParent subscription
1733+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1734+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1735+ forM_ mOldSubd $ \oldSubd -> do
1736+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1737+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1738+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1739+ foldM f ([], oldParents) $ DMap.toList p
1740+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1741+ getInitialSubscribers initialParents subscriber = do
1742+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1743+ let s = subscriber $ return k
1744+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1745+ height <- liftIO $ getEventSubscribedHeight parentSubd
1746+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1747+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1748+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1749+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1750+ )
1751+ destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1752+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1753+
1754+{-# INLINE [1] mergeCheapWithMove #-}
1755+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1756+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1757+ where
1758+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1759+ updateMe subscriber heightBagRef oldParents p = do
1760+ -- Prepare new parents for insertion
1761+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1762+ subscribeParent k e = do
1763+ keyRef <- liftIO $ newIORef k
1764+ let s = subscriber $ liftIO $ readIORef keyRef
1765+ subscription@(EventSubscription _ subd) <- subscribe e s
1766+ liftIO $ do
1767+ newParentHeight <- getEventSubscribedHeight subd
1768+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1769+ return $ MergeSubscribedParentWithMove subscription keyRef
1770+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1771+ -- Collect old parents for deletion and update the keys of moved parents
1772+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1773+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1774+ Nothing -> do
1775+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1776+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1777+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1778+ Just toKey -> do
1779+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1780+ return Nothing
1781+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1782+ return (toDelete, applyAlways p' oldParents)
1783+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1784+ getInitialSubscribers initialParents subscriber = do
1785+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1786+ keyRef <- liftIO $ newIORef k
1787+ let s = subscriber $ liftIO $ readIORef keyRef
1788+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1789+ height <- liftIO $ getEventSubscribedHeight parentSubd
1790+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1791+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1792+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1793+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1794+ )
1795+ destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1796+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1797+
1798+type MergeUpdateFunc k x p s
1799+ = (forall a. EventM x (k a) -> Subscriber x a)
1800+ -> IORef HeightBag
1801+ -> DMap k s
1802+ -> p
1803+ -> EventM x ([EventSubscription x], DMap k s)
1804+
1805+type MergeInitFunc k x s
1806+ = DMap k (Event x)
1807+ -> (forall a. EventM x (k a) -> Subscriber x a)
1808+ -> EventM x (DMap k Identity, [Height], DMap k s)
1809+
1810+type MergeDestroyFunc k s
1811+ = DMap k s
1812+ -> IO ()
1813+
1814+data Merge x k s = Merge
1815+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1816+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1817+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1818+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1819+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1820+ }
1821+
1822+invalidateMergeHeight :: Merge x k s -> IO ()
1823+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1824+
1825+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1826+invalidateMergeHeight' heightRef sub = do
1827+ oldHeight <- readIORef heightRef
1828+ 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
1829+ writeIORef heightRef $! invalidHeight
1830+ subscriberInvalidateHeight sub oldHeight
1831+
1832+
1833+revalidateMergeHeight :: Merge x k s -> IO ()
1834+revalidateMergeHeight m = do
1835+ currentHeight <- readIORef $ _merge_heightRef m
1836+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1837+ heights <- readIORef $ _merge_heightBagRef m
1838+ parents <- readIORef $ _merge_parentsRef m
1839+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1840+ case heightBagSize heights `compare` DMap.size parents of
1841+ LT -> return ()
1842+ EQ -> do
1843+ let height = succHeight $ heightBagMax heights
1844+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1845+ writeIORef (_merge_heightRef m) $! height
1846+ subscriberRecalculateHeight (_merge_sub m) height
1847+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1848+
1849+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1850+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1851+ vals <- liftIO $ readIORef $ _merge_accumRef m
1852+ 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
1853+ --TODO: Assert that m is not empty
1854+ subscriberPropagate (_merge_sub m) vals
1855+
1856+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1857+mergeSubscriber m getKey = Subscriber
1858+ { subscriberPropagate = \a -> do
1859+ oldM <- liftIO $ readIORef $ _merge_accumRef m
1860+ k <- getKey
1861+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1862+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1863+ liftIO $ writeIORef (_merge_accumRef m) $! newM
1864+ when (DMap.null oldM) $ do -- Only schedule the firing once
1865+ height <- liftIO $ readIORef $ _merge_heightRef m
1866+ --TODO: assertions about height
1867+ currentHeight <- getCurrentHeight
1868+ when (height <= currentHeight) $ do
1869+ if height /= invalidHeight
1870+ then do
1871+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1872+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1873+ else liftIO $ do
1874+#ifdef DEBUG_CYCLES
1875+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1876+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1877+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1878+#else
1879+ let cycleInfo = ""
1880+#endif
1881+ error $ "Causality loop found" <> cycleInfo
1882+ scheduleMergeSelf m height
1883+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1884+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1885+ invalidateMergeHeight m
1886+ , subscriberRecalculateHeight = \new -> do
1887+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1888+ revalidateMergeHeight m
1889+ }
1890+
1891+--TODO: Be able to run as much of this as possible promptly
1892+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1893+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1894+ where updateMe = do
1895+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1896+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1897+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1898+ return subscriptionsToKill
1899+
1900+{-# INLINE mergeCheap' #-}
1901+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)
1902+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1903+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1904+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1905+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1906+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1907+ parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1908+ let m = Merge
1909+ { _merge_parentsRef = parentsRef
1910+ , _merge_heightBagRef = heightBagRef
1911+ , _merge_heightRef = heightRef
1912+ , _merge_sub = sub
1913+ , _merge_accumRef = accumRef
1914+ }
1915+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1916+ let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1917+ myHeight = if invalidHeight `elem` heights
1918+ then invalidHeight
1919+ else succHeight $ heightBagMax myHeightBag
1920+ currentHeight <- getCurrentHeight
1921+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1922+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1923+ else (Nothing, dm)
1924+ unless (DMap.null accum) $ do
1925+ scheduleMergeSelf m myHeight
1926+ liftIO $ writeIORef accumRef $! accum
1927+ liftIO $ writeIORef heightRef $! myHeight
1928+ liftIO $ writeIORef heightBagRef $! myHeightBag
1929+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1930+ liftIO $ writeIORef parentsRef $! initialParentState
1931+ defer $ SomeMergeInit $ do
1932+ let s = Subscriber
1933+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1934+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1935+ defer $ updateMerge m updateFunc a
1936+ , subscriberInvalidateHeight = \_ -> return ()
1937+ , subscriberRecalculateHeight = \_ -> return ()
1938+ }
1939+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1940+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
1941+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1942+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1943+ -- its subscription.
1944+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1945+ let unsubscribeAll = destroy =<< readIORef parentsRef
1946+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1947+ , occ
1948+ )
1949+
1950+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1951+mergeInt = cacheEvent . mergeIntCheap
1952+
1953+{-# INLINABLE mergeIntCheap #-}
1954+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1955+mergeIntCheap d = Event $ \sub -> do
1956+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1957+ accum <- liftIO $ FastMutableIntMap.newEmpty
1958+ heightRef <- liftIO $ newIORef zeroHeight
1959+ heightBagRef <- liftIO $ newIORef heightBagEmpty
1960+ parents <- liftIO $ FastMutableIntMap.newEmpty
1961+ let scheduleSelf = do
1962+ height <- liftIO $ readIORef $ heightRef
1963+ scheduleMerge' height heightRef $ do
1964+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
1965+ subscriberPropagate sub vals
1966+ invalidateMyHeight = do
1967+ invalidateMergeHeight' heightRef sub
1968+ recalculateMyHeight = do
1969+ currentHeight <- readIORef heightRef
1970+ 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?
1971+ heights <- readIORef heightBagRef
1972+ numParents <- FastMutableIntMap.size parents
1973+ case heightBagSize heights `compare` numParents of
1974+ LT -> return ()
1975+ EQ -> do
1976+ let height = succHeight $ heightBagMax heights
1977+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1978+ writeIORef heightRef $! height
1979+ subscriberRecalculateHeight sub height
1980+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1981+ mySubscriber k = Subscriber
1982+ { subscriberPropagate = \a -> do
1983+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1984+ liftIO $ FastMutableIntMap.insert accum k a
1985+ when wasEmpty scheduleSelf
1986+ , subscriberInvalidateHeight = \old -> do
1987+ modifyIORef' heightBagRef $ heightBagRemove old
1988+ invalidateMyHeight
1989+ , subscriberRecalculateHeight = \new -> do
1990+ modifyIORef' heightBagRef $ heightBagAdd new
1991+ recalculateMyHeight
1992+ }
1993+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do
1994+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
1995+ liftIO $ do
1996+ forM_ parentOcc $ FastMutableIntMap.insert accum k
1997+ FastMutableIntMap.insert parents k subscription
1998+ height <- getEventSubscribedHeight parentSubd
1999+ if height == invalidHeight
2000+ then writeIORef heightRef invalidHeight
2001+ else do
2002+ modifyIORef' heightBagRef $ heightBagAdd height
2003+ modifyIORef' heightRef $ \oldHeight ->
2004+ if oldHeight == invalidHeight
2005+ then invalidHeight
2006+ else max (succHeight height) oldHeight
2007+ myHeight <- liftIO $ readIORef heightRef
2008+ currentHeight <- getCurrentHeight
2009+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
2010+ occ <- if currentHeight >= myHeight -- If we should have fired by now
2011+ then if isEmpty
2012+ then return Nothing
2013+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2014+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2015+ return Nothing
2016+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2017+ defer $ SomeMergeInit $ do
2018+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2019+ where
2020+ u = do
2021+ let f k newParent = do
2022+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
2023+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
2024+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
2025+ return subscription
2026+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
2027+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2028+ liftIO $ for_ oldParents $ \oldParent -> do
2029+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2030+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2031+ return $ IntMap.elems oldParents
2032+ let s = Subscriber
2033+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2034+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2035+ defer $ updateMe a
2036+ , subscriberInvalidateHeight = \_ -> return ()
2037+ , subscriberRecalculateHeight = \_ -> return ()
2038+ }
2039+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2040+ forM_ change $ \c -> defer $ updateMe c
2041+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2042+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2043+ -- its subscription.
2044+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2045+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2046+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2047+ , occ
2048+ )
2049+
2050+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2051+
2052+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2053+fan e =
2054+ let f = Fan
2055+ { fanParent = e
2056+ , fanSubscribed = unsafeNewIORef e Nothing
2057+ }
2058+ in EventSelector $ \k -> eventFan k f
2059+
2060+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2061+runHoldInits holdInitRef dynInitRef mergeInitRef = do
2062+ holdInits <- liftIO $ readIORef holdInitRef
2063+ dynInits <- liftIO $ readIORef dynInitRef
2064+ mergeInits <- liftIO $ readIORef mergeInitRef
2065+ unless (null holdInits && null dynInits && null mergeInits) $ do
2066+ liftIO $ writeIORef holdInitRef []
2067+ liftIO $ writeIORef dynInitRef []
2068+ liftIO $ writeIORef mergeInitRef []
2069+ mapM_ initHold holdInits
2070+ mapM_ initDyn dynInits
2071+ mapM_ unSomeMergeInit mergeInits
2072+ runHoldInits holdInitRef dynInitRef mergeInitRef
2073+
2074+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2075+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2076+
2077+initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2078+initDyn (SomeDynInit d) = void $ getDynHold d
2079+
2080+newEventEnv :: IO (EventEnv x)
2081+newEventEnv = do
2082+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2083+ holdInitRef <- newIORef []
2084+ dynInitRef <- newIORef []
2085+ mergeUpdateRef <- newIORef []
2086+ mergeInitRef <- newIORef []
2087+ heightRef <- newIORef zeroHeight
2088+ toClearRef <- newIORef []
2089+ toClearIntRef <- newIORef []
2090+ toClearRootRef <- newIORef []
2091+ coincidenceInfosRef <- newIORef []
2092+ delayedRef <- newIORef IntMap.empty
2093+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2094+
2095+clearEventEnv :: EventEnv x -> IO ()
2096+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2097+ writeIORef toAssignRef []
2098+ writeIORef holdInitRef []
2099+ writeIORef dynInitRef []
2100+ writeIORef mergeUpdateRef []
2101+ writeIORef mergeInitRef []
2102+ writeIORef heightRef zeroHeight
2103+ writeIORef toClearRef []
2104+ writeIORef toClearIntRef []
2105+ writeIORef toClearRootRef []
2106+ writeIORef coincidenceInfosRef []
2107+ writeIORef delayedRef IntMap.empty
2108+
2109+-- | Run an event action outside of a frame
2110+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2111+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2112+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2113+ let go = do
2114+ result <- a
2115+ 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
2116+ return result
2117+ result <- runEventM go
2118+ toClear <- readIORef $ eventEnvClears env
2119+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2120+ toClearInt <- readIORef $ eventEnvIntClears env
2121+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2122+ toClearRoot <- readIORef $ eventEnvRootClears env
2123+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2124+ toAssign <- readIORef $ eventEnvAssignments env
2125+ toReconnectRef <- newIORef []
2126+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2127+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2128+ writeIORef vRef v
2129+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
2130+ writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2131+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2132+ writeIORef (eventEnvMergeUpdates env) []
2133+ when debugPropagate $ putStrLn "Updating merges"
2134+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2135+ when debugPropagate $ putStrLn "Updating merges done"
2136+ toReconnect <- readIORef toReconnectRef
2137+ clearEventEnv env
2138+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2139+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2140+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2141+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2142+ finalize wi
2143+ i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2144+ wi' <- mkWeakPtrWithDebug i "wi'"
2145+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2146+ writeIORef (switchSubscribedBehaviorParents subscribed) []
2147+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2148+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2149+ 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
2150+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2151+ sub <- newSubscriberSwitch subscribed
2152+ 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
2153+ {-
2154+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2155+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2156+ EventRoot _ -> "EventRoot"
2157+ EventNever -> "EventNever"
2158+ _ -> "something else"
2159+ -}
2160+ writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2161+ return oldSubscription
2162+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2163+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2164+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2165+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2166+ parentHeight <- getEventSubscribedHeight subd'
2167+ myHeight <- readIORef $ switchSubscribedHeight subscribed
2168+ when (parentHeight /= myHeight) $ do
2169+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2170+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2171+ 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
2172+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2173+ unsubscribe subscription
2174+ mapM_ invalidateCoincidenceHeight mcs
2175+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2176+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2177+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2178+ height <- calculateSwitchHeight subscribed
2179+ updateSwitchHeight height subscribed
2180+ return result
2181+
2182+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2183+
2184+{-# INLINE zeroHeight #-}
2185+zeroHeight :: Height
2186+zeroHeight = Height 0
2187+
2188+{-# INLINE invalidHeight #-}
2189+invalidHeight :: Height
2190+invalidHeight = Height (-1000)
2191+
2192+#ifdef DEBUG_CYCLES
2193+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2194+{-# INLINE invalidHeightBeingTraversed #-}
2195+invalidHeightBeingTraversed :: Height
2196+invalidHeightBeingTraversed = Height (-1001)
2197+#endif
2198+
2199+{-# INLINE succHeight #-}
2200+succHeight :: Height -> Height
2201+succHeight h@(Height a) =
2202+ if h == invalidHeight
2203+ then invalidHeight
2204+ else Height $ succ a
2205+
2206+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2207+invalidateCoincidenceHeight subscribed = do
2208+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2209+ when (oldHeight /= invalidHeight) $ do
2210+ writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2211+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2212+
2213+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2214+updateSwitchHeight new subscribed = do
2215+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
2216+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2217+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2218+ writeIORef (switchSubscribedHeight subscribed) $! new
2219+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2220+
2221+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2222+recalculateCoincidenceHeight subscribed = do
2223+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2224+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2225+ height <- calculateCoincidenceHeight subscribed
2226+ when (height /= invalidHeight) $ do
2227+ writeIORef (coincidenceSubscribedHeight subscribed) $! height
2228+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2229+
2230+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2231+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2232+
2233+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2234+calculateCoincidenceHeight subscribed = do
2235+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2236+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2237+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2238+
2239+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2240+
2241+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2242+invalidate toReconnectRef wis = do
2243+ forM_ wis $ \wi -> do
2244+ mi <- deRefWeak wi
2245+ case mi of
2246+ Nothing -> do
2247+ traceInvalidate "invalidate Dead"
2248+ return () --TODO: Should we clean this up here?
2249+ Just i -> do
2250+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2251+ case i of
2252+ InvalidatorPull p -> do
2253+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
2254+ mVal <- readIORef $ pullValue p
2255+ forM_ mVal $ \val -> do
2256+ writeIORef (pullValue p) Nothing
2257+ writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2258+ InvalidatorSwitch subscribed -> do
2259+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2260+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2261+ 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
2262+
2263+--------------------------------------------------------------------------------
2264+-- Reflex integration
2265+--------------------------------------------------------------------------------
2266+
2267+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2268+-- When we're specializing, we include this from Reflex.Class instead, because
2269+-- it needs access to these types; when we're not, we want them here, so our
2270+-- instance isn't an orphan instance.
2271+#include "SpiderTimeline.include.hs"
2272+#include "SpiderTimelineHost.include.hs"
2273+#endif
2274+
2275+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2276+unsafeNewSpiderTimelineEnv = do
2277+ lock <- newMVar ()
2278+ env <- newEventEnv
2279+#ifdef DEBUG
2280+ depthRef <- newIORef 0
2281+#endif
2282+ return $ SpiderTimelineEnv
2283+ { _spiderTimeline_lock = lock
2284+ , _spiderTimeline_eventEnv = env
2285+#ifdef DEBUG
2286+ , _spiderTimeline_depth = depthRef
2287+#endif
2288+ }
2289+
2290+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2291+-- | Create a new SpiderTimelineEnv
2292+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2293+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2294+
2295+data LocalSpiderTimeline x s
2296+
2297+instance Reifies s (SpiderTimelineEnv x) =>
2298+ HasSpiderTimeline (LocalSpiderTimeline x s) where
2299+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2300+
2301+localSpiderTimeline
2302+ :: Proxy s
2303+ -> SpiderTimelineEnv x
2304+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2305+localSpiderTimeline _ = unsafeCoerce
2306+
2307+-- | Pass a new timeline to the given function.
2308+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2309+withSpiderTimeline k = do
2310+ env <- unsafeNewSpiderTimelineEnv
2311+ reify env $ \s -> k $ localSpiderTimeline s env
2312+#endif
2313+
2314+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2315+
2316+type ComputeM = EventM
2317+
2318+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2319+
2320+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2321+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2322+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2323+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2324+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2325+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2326+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2327+ type PullM (SpiderTimeline x) = SpiderPullM x
2328+ type PushM (SpiderTimeline x) = SpiderPushM x
2329+ {-# INLINABLE never #-}
2330+ never = SpiderEvent eventNever
2331+ {-# INLINABLE constant #-}
2332+ constant = SpiderBehavior . behaviorConst
2333+ {-# INLINE push #-}
2334+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
2335+ {-# INLINE pushCheap #-}
2336+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2337+ {-# INLINABLE pull #-}
2338+ pull = SpiderBehavior . pull . coerce
2339+ {-# INLINABLE merge #-}
2340+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2341+ {-# INLINABLE fan #-}
2342+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2343+ {-# INLINABLE switch #-}
2344+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2345+ {-# INLINABLE coincidence #-}
2346+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2347+ {-# INLINABLE current #-}
2348+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2349+ {-# INLINABLE updated #-}
2350+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2351+ {-# INLINABLE unsafeBuildDynamic #-}
2352+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2353+ {-# INLINABLE unsafeBuildIncremental #-}
2354+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2355+ {-# INLINABLE mergeIncremental #-}
2356+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2357+ {-# INLINABLE mergeIncrementalWithMove #-}
2358+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2359+ {-# INLINABLE currentIncremental #-}
2360+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2361+ {-# INLINABLE updatedIncremental #-}
2362+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2363+ {-# INLINABLE incrementalToDynamic #-}
2364+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2365+ c <- readBehaviorUntracked $ dynamicCurrent i
2366+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2367+ eventCoercion Coercion = Coercion
2368+ behaviorCoercion Coercion = Coercion
2369+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2370+ {-# INLINABLE mergeIntIncremental #-}
2371+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2372+ {-# INLINABLE fanInt #-}
2373+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2374+#endif
2375+
2376+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2377+
2378+data SpiderEventHandle x a = SpiderEventHandle
2379+ { spiderEventHandleSubscription :: EventSubscription x
2380+ , spiderEventHandleValue :: IORef (Maybe a)
2381+ }
2382+
2383+instance MonadRef (EventM x) where
2384+ type Ref (EventM x) = Ref IO
2385+ {-# INLINABLE newRef #-}
2386+ {-# INLINABLE readRef #-}
2387+ {-# INLINABLE writeRef #-}
2388+ newRef = liftIO . newRef
2389+ readRef = liftIO . readRef
2390+ writeRef r a = liftIO $ writeRef r a
2391+
2392+instance MonadAtomicRef (EventM x) where
2393+ {-# INLINABLE atomicModifyRef #-}
2394+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
2395+
2396+-- | The monad for actions that manipulate a Spider timeline identified by @x@
2397+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2398+
2399+instance Monad (SpiderHost x) where
2400+ {-# INLINABLE (>>=) #-}
2401+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2402+ {-# INLINABLE (>>) #-}
2403+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2404+ {-# INLINABLE return #-}
2405+ return x = SpiderHost $ return x
2406+ {-# INLINABLE fail #-}
2407+ fail s = SpiderHost $ fail s
2408+
2409+-- | Run an action affecting the global Spider timeline; this will be guarded by
2410+-- a mutex for that timeline
2411+runSpiderHost :: SpiderHost Global a -> IO a
2412+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2413+
2414+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2415+-- | Run an action affecting a given Spider timeline; this will be guarded by a
2416+-- mutex for that timeline
2417+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2418+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2419+#endif
2420+
2421+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2422+
2423+instance Monad (SpiderHostFrame x) where
2424+ {-# INLINABLE (>>=) #-}
2425+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2426+ {-# INLINABLE (>>) #-}
2427+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2428+ {-# INLINABLE return #-}
2429+ return x = SpiderHostFrame $ return x
2430+ {-# INLINABLE fail #-}
2431+ fail s = SpiderHostFrame $ fail s
2432+
2433+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2434+newEventWithTriggerIO f = do
2435+ es <- newFanEventWithTriggerIO $ \Refl -> f
2436+ return $ select es Refl
2437+
2438+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2439+newFanEventWithTriggerIO f = do
2440+ occRef <- newIORef DMap.empty
2441+ subscribedRef <- newIORef DMap.empty
2442+ let !r = Root
2443+ { rootOccurrence = occRef
2444+ , rootSubscribed = subscribedRef
2445+ , rootInit = f
2446+ }
2447+ return $ EventSelector $ \k -> eventRoot k r
2448+
2449+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2450+
2451+instance MonadRef (SpiderHost x) where
2452+ type Ref (SpiderHost x) = Ref IO
2453+ newRef = SpiderHost . newRef
2454+ readRef = SpiderHost . readRef
2455+ writeRef r = SpiderHost . writeRef r
2456+
2457+instance MonadAtomicRef (SpiderHost x) where
2458+ atomicModifyRef r = SpiderHost . atomicModifyRef r
2459+
2460+instance MonadRef (SpiderHostFrame x) where
2461+ type Ref (SpiderHostFrame x) = Ref IO
2462+ newRef = SpiderHostFrame . newRef
2463+ readRef = SpiderHostFrame . readRef
2464+ writeRef r = SpiderHostFrame . writeRef r
2465+
2466+instance MonadAtomicRef (SpiderHostFrame x) where
2467+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2468+
2469+instance PrimMonad (SpiderHostFrame x) where
2470+ type PrimState (SpiderHostFrame x) = PrimState IO
2471+ 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+135
@@ -0,0 +1,135 @@
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+ {-# INLINABLE buildDynamic #-}
118+ buildDynamic a0 = lift . buildDynamic a0
119+ {-# INLINABLE headE #-}
120+ headE = lift . headE
121+
122+instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where
123+ {-# INLINABLE runWithReplace #-}
124+ runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')
125+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
126+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'
127+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
128+ traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'
129+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
130+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'
131+
132+-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
133+-- be fired.
134+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
135+askEvents = TriggerEventT ask
src/Reflex/TriggerEvent/Class.hsnew file+50
@@ -0,0 +1,50 @@
1+-- | This module defines 'TriggerEvent', which describes actions that may create
2+-- new 'Event's that can be triggered from 'IO'.
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+module Reflex.TriggerEvent.Class
8+ ( TriggerEvent (..)
9+ ) where
10+
11+import Reflex.Class
12+
13+import Control.Monad.Reader
14+import Control.Monad.State
15+import qualified Control.Monad.State.Strict as Strict
16+
17+--TODO: Shouldn't have IO hard-coded
18+-- | 'TriggerEvent' represents actions that can create 'Event's that can be
19+-- triggered by 'IO' actions.
20+class Monad m => TriggerEvent t m | m -> t where
21+ -- | Create a triggerable 'Event'. Whenever the resulting function is called,
22+ -- the resulting 'Event' will fire at some point in the future. Note that
23+ -- this may not be synchronous.
24+ newTriggerEvent :: m (Event t a, a -> IO ())
25+ -- | Like 'newTriggerEvent', but the callback itself takes another callback,
26+ -- to be invoked once the requested 'Event' occurrence has finished firing.
27+ -- This allows synchronous operation.
28+ newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow
29+ -- | Like 'newTriggerEventWithOnComplete', but with setup and teardown. This
30+ -- relatively complex type signature allows any external listeners to be
31+ -- subscribed lazily and then removed whenever the returned 'Event' is no
32+ -- longer being listened to. Note that the setup/teardown may happen multiple
33+ -- times, and there is no guarantee that the teardown will be executed
34+ -- promptly, or even at all, in the case of program termination.
35+ newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)
36+
37+instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where
38+ newTriggerEvent = lift newTriggerEvent
39+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
40+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
41+
42+instance TriggerEvent t m => TriggerEvent t (StateT s m) where
43+ newTriggerEvent = lift newTriggerEvent
44+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
45+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
46+
47+instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where
48+ newTriggerEvent = lift newTriggerEvent
49+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
50+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
src/Reflex/Widget/Basic.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ExplicitForAll #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE RecursiveDo #-}
5+#ifdef USE_REFLEX_OPTIMIZER
6+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
7+#endif
8+
9+module Reflex.Widget.Basic where
10+
11+import Control.Monad.Fix (MonadFix)
12+import Data.Map (Map)
13+import Reflex.Class
14+import Reflex.Patch.MapWithMove
15+
16+
17+-- | Build sortable content in such a way that re-sorting it can cause minimal
18+-- disruption to an existing context.
19+--
20+-- Naively re-sorting a list of images would destroy every image and add them back
21+-- in the new order. This framework is able to avoid that by preserving the
22+-- identity of each image and simply moving it to the new location.
23+--
24+-- Example:
25+--
26+-- > let sortByFst = buttonA $> comparing fst
27+-- > sortBySnd = buttonB $> comparing snd
28+-- > sortEvent = leftmost [sortByFst, sortBySnd]
29+-- > sortableList
30+-- > (\k v -> text $ "\n" ++ show k ++ " " ++ v) -- show each element on a new line
31+-- > (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")])
32+-- > sortEvent
33+sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, MonadAdjust t m, Ord k)
34+ => (k -> v -> m a) -- ^ Function to render the content for each key/value pair
35+ -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order
36+ -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list
37+ -> m (Map k a)
38+sortableList f m0 reSortFunc = do
39+ rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc
40+ m <- holdIncremental m0 reSortPatch
41+ (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch
42+ pure results
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