git.iko.soy/patch
on 4a59bfa help sign in
b6af869
swap
0 ahead, 630 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+16
@@ -0,0 +1,16 @@
1+# Cache Buster: 0
2+language: nix
3+cache:
4+ directories:
5+ - /nix
6+matrix:
7+ include:
8+ - env: COMPILER=ghc7103
9+ - env: COMPILER=ghc821
10+ - env: COMPILER=ghc802
11+ - env: COMPILER=ghcjs
12+script:
13+ - set -e
14+ - nix-build -E "with (import <nixpkgs> {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }"
15+ - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed
16+
CONTRIBUTING.mddeleted−66
@@ -1,66 +0,0 @@
1−# Contribution Guide
2−
3−Contributions and issue reports are encouraged and appreciated!
4−
5−- [Opening Issues](#opening-issues)
6−- [Submitting Changes](#submitting-changes)
7− - [Guidelines for Commit Messages](#guidelines-for-commit-messages)
8− - [Guidelines for Pull Requests](#guidelines-for-pull-requests)
9− - [Code Quality](#code-quality)
10− - [Documentation](#documentation)
11−
12−## Opening Issues
13−
14−Before opening an issue, please check whether your issue has already been reported. Assuming it has not:
15−
16−* Describe the issue you're encountering or the suggestion you're making
17−* Include any relevant steps to reproduce or code samples you can. It's always easier for us to debug if we have something that demonstrates the error.
18−* Let us know what version of patch you were using. If you're using a github checkout, provide the git hash.
19−* Describe how you're building patch (i.e., via reflex-platform, cabal install, stack, obelisk, etc.). If you're using reflex-platform or obelisk, provide the git hash of your checkout.
20−
21−## Submitting Changes
22−
23−### Guidelines for Commit Messages
24−
25−#### Summary Line
26−The summary line of your commit message should summarize the changes being made. Commit messages should be written in the imperative mood and should describe what happens when the commit is applied.
27−
28−One way to think about it is that your commit message should be able to complete the sentence:
29−"When applied, this commit will..."
30−
31−#### Body
32−For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.
33−
34−### Guidelines for Pull Requests
35−
36−Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes.
37−
38−### Code Quality
39−
40−#### Warnings
41−
42−Your pull request should add no new warnings to the project. It should also generally not disable any warnings.
43−
44−#### Build and Test
45−
46−Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!
47−
48−#### Dependencies
49−
50−Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to patch.cabal also need to be added to default.nix.
51−
52−### Documentation
53−
54−#### In the code
55−We're always striving to improve documentation. Please include [haddock](https://haskell-haddock.readthedocs.io/en/latest/index.html) documentation for any added code, and update the documentation for any code you modify.
56−
57−#### In the [Changelog](ChangeLog.md)
58−Add an entry to the changelog when your PR:
59−* Adds a feature
60−* Deprecates something
61−* Includes a breaking change
62−* Makes any other change that will impact users
63−
64−#### In the [Readme](README.md)
65−The readme is the first place a lot of people look for information about the repository. Update any parts of the readme that are affected by your PR.
66−
ChangeLog.mddeleted−61
@@ -1,61 +0,0 @@
1−# Revision history for patch
2−
3−## Unreleased
4−
5−* New dep of `data-orphans` for old GHC to get instances honestly instead of
6− via `monoidal-containers`.
7−
8−## 0.0.5.0 - 2021-12-17
9−
10−* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
11− from `Data.Patch` for compatability.
12−
13−* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
14− Care is taken to make this not a breaking change.
15− In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
16− There are complete constructor and field patterns too, and everything is
17− exported under the newtype as real constructors and fields would be.
18−
19−## 0.0.4.0 - 2021-04-20
20−
21−* Enable PolyKinds
22−
23−## 0.0.3.2 - 2020-11-06
24−
25−* Update version bounds
26−
27−## 0.0.3.1 - 2020-02-05
28−
29−* Replace `fromJust` with something easier to debug.
30−
31−## 0.0.3.0 - 2020-02-05
32−
33−* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
34−
35−* Create `DecidablyEmpty` subclass of `Monoid`.
36−
37−## 0.0.2.0 - 2020-01-17
38−
39−* Consistently provide:
40−
41− - `Wrapped` instances
42−
43− - `*WithIndex` instances
44−
45− - `un*` newtype unwrappers
46−
47− for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
48−
49−## 0.0.1.0 - 2020-01-09
50−
51−* Support older GHCs with `split-these` flag.
52−
53−* Additional instances for the `Group` class for basic types.
54−
55−## 0.0.0.1 - 2020-01-08
56−
57−* Remove unneeded dependencies
58−
59−## 0.0.0.0 - 2020-01-08
60−
61−* Extract patching functionality from Reflex.
Quickref.mdnew file+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+36
@@ -0,0 +1,36 @@
1+{ mkDerivation, ghc, base, bifunctors, containers, deepseq
2+, dependent-map, dependent-sum, exception-transformers
3+, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
4+, monad-control, mtl, primitive, random, ref-tf
5+, semigroupoids , semigroups, split, stdenv, stm, syb
6+, template-haskell , these, time, transformers
7+, transformers-compat, unbounded-delays, prim-uniq
8+, data-default , filepath, directory, filemanip
9+, useTemplateHaskell ? true
10+}:
11+mkDerivation {
12+ pname = "reflex";
13+ version = "0.5.0";
14+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
15+ libraryHaskellDepends = [
16+ base bifunctors containers dependent-map dependent-sum
17+ exception-transformers lens
18+ MemoTrie monad-control mtl primitive ref-tf semigroupoids
19+ semigroups stm syb template-haskell these transformers
20+ transformers-compat prim-uniq
21+ base bifunctors containers deepseq dependent-map dependent-sum
22+ mtl ref-tf split transformers data-default
23+ random time unbounded-delays
24+ ] ++ (if !useTemplateHaskell then [] else [
25+ haskell-src-exts haskell-src-meta
26+ ]);
27+ testHaskellDepends = if ghc.isGhcjs or false then [] else [
28+ hlint filepath directory filemanip
29+ ];
30+ configureFlags = if useTemplateHaskell then [] else [
31+ "-f-use-template-haskell"
32+ ];
33+ homepage = "https://github.com/reflex-frp/reflex";
34+ description = "Higher-order Functional Reactive Programming";
35+ license = stdenv.lib.licenses.bsd3;
36+}
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+316
@@ -0,0 +1,316 @@
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+flag fast-weak
47+ description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default
48+ default: False
49+ manual: True
50+
51+library
52+ hs-source-dirs: src
53+ build-depends:
54+ MemoTrie == 0.6.*,
55+ base >= 4.7 && < 4.11,
56+ bifunctors >= 5.2 && < 5.5,
57+ comonad,
58+ containers == 0.5.*,
59+ data-default >= 0.5 && < 0.8,
60+ dependent-map >= 0.2.4 && < 0.3,
61+ exception-transformers == 0.4.*,
62+ lens >= 4.7 && < 5,
63+ monad-control >= 1.0.1 && < 1.1,
64+ mtl >= 2.1 && < 2.3,
65+ prim-uniq >= 0.1.0.1 && < 0.2,
66+ primitive >= 0.5 && < 0.7,
67+ random == 1.1.*,
68+ ref-tf == 0.4.*,
69+ reflection == 2.1.*,
70+ semigroupoids >= 4.0 && < 6,
71+ semigroups >= 0.16 && < 0.19,
72+ stm == 2.4.*,
73+ syb >= 0.5 && < 0.8,
74+ these >= 0.4 && < 0.8,
75+ time >= 1.4 && < 1.9,
76+ transformers >= 0.2,
77+ transformers-compat >= 0.3,
78+ unbounded-delays >= 0.1.0.0 && < 0.2
79+
80+ exposed-modules:
81+ Data.AppendMap,
82+ Data.Functor.Misc,
83+ Data.WeakBag,
84+ Data.FastWeakBag,
85+ Data.FastMutableIntMap,
86+ Reflex,
87+ Reflex.Class,
88+ Reflex.EventWriter,
89+ Reflex.Dynamic,
90+ Reflex.Dynamic.Uniq,
91+ Reflex.DynamicWriter,
92+ Reflex.FastWeak,
93+ Reflex.FunctorMaybe,
94+ Reflex.Host.Class,
95+ Reflex.Patch,
96+ Reflex.Patch.Class,
97+ Reflex.Patch.DMap,
98+ Reflex.Patch.DMapWithMove,
99+ Reflex.Patch.Map,
100+ Reflex.Patch.MapWithMove,
101+ Reflex.TriggerEvent.Base,
102+ Reflex.TriggerEvent.Class,
103+ Reflex.PerformEvent.Base,
104+ Reflex.PerformEvent.Class,
105+ Reflex.PostBuild.Base,
106+ Reflex.PostBuild.Class,
107+ Reflex.Profiled,
108+ Reflex.Query.Base,
109+ Reflex.Query.Class,
110+ Reflex.Requester.Base,
111+ Reflex.Requester.Class,
112+ Reflex.Spider,
113+ Reflex.Spider.Internal,
114+ Reflex.Time,
115+ Reflex.Widget.Basic
116+
117+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo
118+ ghc-prof-options: -fprof-auto
119+
120+ if flag(specialize-to-spidertimeline-global)
121+ cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
122+ else
123+ exposed-modules: Reflex.Pure
124+
125+ if flag(debug-trace-events)
126+ cpp-options: -DDEBUG_TRACE_EVENTS
127+ build-depends: bytestring
128+
129+ if flag(use-reflex-optimizer)
130+ cpp-options: -DUSE_REFLEX_OPTIMIZER
131+ build-depends: ghc
132+ exposed-modules: Reflex.Optimizer
133+
134+ if flag(use-template-haskell)
135+ cpp-options: -DUSE_TEMPLATE_HASKELL
136+ build-depends:
137+ dependent-sum >= 0.3 && < 0.5,
138+ haskell-src-exts >= 1.16 && < 1.19,
139+ haskell-src-meta >= 0.6 && < 0.9,
140+ template-haskell >= 2.9 && < 2.13
141+ exposed-modules:
142+ Reflex.Dynamic.TH
143+ other-extensions: TemplateHaskell
144+ else
145+ build-depends:
146+ dependent-sum == 0.4.*
147+
148+ if flag(expose-all-unfoldings)
149+ ghc-options: -fexpose-all-unfoldings
150+
151+ if flag(experimental-dependent-sum-instances)
152+ ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES
153+
154+ if flag(fast-weak) && impl(ghcjs)
155+ ghc-options: -DGHCJS_FAST_WEAK
156+
157+ if impl(ghcjs)
158+ build-depends: ghcjs-base
159+
160+test-suite semantics
161+ type: exitcode-stdio-1.0
162+ main-is: semantics.hs
163+ hs-source-dirs: test
164+ ghc-options: -O2 -Wall -rtsopts
165+ build-depends:
166+ base,
167+ bifunctors,
168+ containers,
169+ deepseq >= 1.3 && < 1.5,
170+ dependent-map,
171+ dependent-sum,
172+ mtl,
173+ ref-tf,
174+ reflex,
175+ split,
176+ transformers >= 0.3
177+ if flag(specialize-to-spidertimeline-global)
178+ buildable: False
179+
180+test-suite CrossImpl
181+ type: exitcode-stdio-1.0
182+ main-is: Reflex/Test/CrossImpl.hs
183+ hs-source-dirs: test
184+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test
185+ build-depends:
186+ base,
187+ containers,
188+ dependent-map,
189+ mtl,
190+ ref-tf,
191+ reflex
192+ if flag(specialize-to-spidertimeline-global)
193+ buildable: False
194+
195+test-suite hlint
196+ type: exitcode-stdio-1.0
197+ main-is: hlint.hs
198+ hs-source-dirs: test
199+ build-depends: base
200+ , directory
201+ , filepath
202+ , filemanip
203+ , hlint
204+ if impl(ghcjs)
205+ buildable: False
206+ buildable: False
207+
208+test-suite EventWriterT
209+ type: exitcode-stdio-1.0
210+ main-is: EventWriterT.hs
211+ hs-source-dirs: test
212+ build-depends: base
213+ , dependent-sum
214+ , lens
215+ , these
216+ , transformers
217+ , reflex
218+ , ref-tf
219+
220+test-suite RequesterT
221+ type: exitcode-stdio-1.0
222+ main-is: RequesterT.hs
223+ hs-source-dirs: test
224+ build-depends: base
225+ , dependent-sum
226+ , dependent-map
227+ , lens
228+ , these
229+ , transformers
230+ , reflex
231+ , ref-tf
232+ buildable: False
233+
234+test-suite QueryT
235+ type: exitcode-stdio-1.0
236+ main-is: QueryT.hs
237+ hs-source-dirs: test
238+ build-depends: base
239+ , containers
240+ , dependent-sum
241+ , dependent-map
242+ , lens
243+ , these
244+ , transformers
245+ , semigroups
246+ , reflex
247+ , ref-tf
248+
249+test-suite GC-Semantics
250+ type: exitcode-stdio-1.0
251+ main-is: GC.hs
252+ hs-source-dirs: test
253+ if flag(specialize-to-spidertimeline-global)
254+ buildable: False
255+ build-depends: base
256+ , dependent-sum
257+ , dependent-map
258+ , these
259+ , transformers
260+ , reflex
261+ , ref-tf
262+ if impl(ghc < 8)
263+ build-depends: semigroups
264+
265+test-suite rootCleanup
266+ type: exitcode-stdio-1.0
267+ main-is: rootCleanup.hs
268+ hs-source-dirs: test
269+ build-depends: base
270+ , reflex
271+
272+benchmark spider-bench
273+ type: exitcode-stdio-1.0
274+ hs-source-dirs: bench
275+ main-is: Main.hs
276+ ghc-options: -Wall -O2 -rtsopts
277+ build-depends:
278+ base,
279+ criterion == 1.1.*,
280+ deepseq >= 1.3 && < 1.5,
281+ dependent-map,
282+ dependent-sum,
283+ mtl,
284+ primitive,
285+ reflex,
286+ stm,
287+ transformers >= 0.3
288+
289+benchmark saulzar-bench
290+ type: exitcode-stdio-1.0
291+ hs-source-dirs: bench test
292+ c-sources: bench-cbits/checkCapability.c
293+ main-is: RunAll.hs
294+ ghc-options: -Wall -O2 -rtsopts -threaded
295+ ghc-prof-options: -fprof-auto
296+ build-depends:
297+ base,
298+ containers == 0.5.*,
299+ criterion == 1.1.*,
300+ deepseq >= 1.3 && < 1.5,
301+ dependent-map,
302+ dependent-sum,
303+ loch-th,
304+ mtl,
305+ primitive,
306+ process,
307+ ref-tf,
308+ reflex,
309+ split,
310+ stm,
311+ time,
312+ transformers >= 0.3
313+
314+source-repository head
315+ type: git
316+ 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_FAST_WEAK
7+{-# LANGUAGE ForeignFunctionInterface #-}
8+{-# LANGUAGE JavaScriptFFI #-}
9+#endif
10+-- | This module defines the 'FastWeakBag' type, which represents a mutable
11+-- collection of items that does not cause the items to be retained in memory.
12+-- This is useful for situations where a value needs to be inspected or modified
13+-- if it is still alive, but can be ignored if it is dead.
14+module Data.FastWeakBag
15+ ( FastWeakBag
16+ , FastWeakBagTicket
17+ , empty
18+ , isEmpty
19+ , insert
20+ , traverse
21+ , remove
22+ -- * Internal functions
23+ -- These will not always be available.
24+#ifndef GHCJS_FAST_WEAK
25+ , _weakBag_children --TODO: Don't export this
26+#endif
27+ ) where
28+
29+import Control.Monad hiding (forM_, mapM_)
30+import Control.Monad.IO.Class
31+
32+#ifdef GHCJS_FAST_WEAK
33+import GHCJS.Types
34+import Reflex.FastWeak (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_FAST_WEAK
50+newtype FastWeakBag a = FastWeakBag JSVal
51+#else
52+data FastWeakBag a = FastWeakBag
53+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
54+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
55+ }
56+#endif
57+
58+-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If
59+-- the caller retains the ticket, the item is guranteed to stay in memory (and
60+-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from
61+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
62+#ifdef GHCJS_FAST_WEAK
63+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
64+#else
65+data FastWeakBagTicket a = FastWeakBagTicket
66+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
67+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
68+ }
69+#endif
70+
71+-- | Insert an item into a 'FastWeakBag'.
72+{-# INLINE insert #-}
73+insert :: a -- ^ The item
74+ -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
75+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
76+ -- is retained and allows the item to be removed.
77+#ifdef GHCJS_FAST_WEAK
78+insert a wb = js_insert (unsafeToRawJSVal a) wb
79+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
80+#else
81+insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
82+ a' <- evaluate a
83+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
84+ let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())
85+ wa <- mkWeakPtr a' $ Just cleanup
86+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
87+ return $ FastWeakBagTicket
88+ { _weakBagTicket_weakItem = wa
89+ , _weakBagTicket_item = a'
90+ }
91+#endif
92+
93+-- | Create an empty 'FastWeakBag'.
94+{-# INLINE empty #-}
95+empty :: IO (FastWeakBag a)
96+#ifdef GHCJS_FAST_WEAK
97+empty = js_empty
98+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
99+#else
100+empty = {-# SCC "empty" #-} do
101+ nextId <- newIORef 1
102+ children <- newIORef IntMap.empty
103+ let bag = FastWeakBag
104+ { _weakBag_nextId = nextId
105+ , _weakBag_children = children
106+ }
107+ return bag
108+#endif
109+
110+-- | Check whether a 'FastWeakBag' is empty.
111+{-# INLINE isEmpty #-}
112+isEmpty :: FastWeakBag a -> IO Bool
113+#ifdef GHCJS_FAST_WEAK
114+isEmpty = js_isEmpty
115+foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time
116+#else
117+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
118+#endif
119+
120+{-# INLINE traverse #-}
121+-- | Visit every node in the given list. If new nodes are appended during the
122+-- traversal, they will not be visited. Every live node that was in the list
123+-- when the traversal began will be visited exactly once; however, no guarantee
124+-- is made about the order of the traversal.
125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
126+#ifdef GHCJS_FAST_WEAK
127+traverse wb f = do
128+ let go cursor = when (not $ js_isNull cursor) $ do
129+ val <- liftIO $ js_getTicketValue cursor
130+ f $ unsafeFromRawJSVal val
131+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
132+ go =<< liftIO (js_getInitial wb)
133+foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
134+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
135+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag
136+foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
137+#else
138+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
139+ cs <- liftIO $ readIORef children
140+ forM_ cs $ \c -> do
141+ ma <- liftIO $ deRefWeak c
142+ mapM_ f ma
143+#endif
144+
145+-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
146+-- on the same 'FastWeakBagTicket'.
147+{-# INLINE remove #-}
148+remove :: FastWeakBagTicket a -> IO ()
149+#ifdef GHCJS_FAST_WEAK
150+remove = js_remove
151+foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here
152+#else
153+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w
154+#endif
155+--TODO: Should 'remove' also drop the reference to the item?
156+
157+--TODO: can/should we provide a null FastWeakBagTicket?
src/Data/Functor/Misc.hs+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+28
@@ -0,0 +1,28 @@
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.Time as X
27+import Reflex.TriggerEvent.Base as X
28+import Reflex.TriggerEvent.Class as X
src/Reflex/Class.hsnew file+1262
@@ -0,0 +1,1262 @@
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+ , filterLeft
122+ , filterRight
123+ -- * Miscellaneous convenience functions
124+ , ffor
125+ , MonadAdjust (..)
126+ , sequenceDMapWithAdjust
127+ , sequenceDMapWithAdjustWithMove
128+ , mapMapWithAdjustWithMove
129+ -- * Deprecated functions
130+ , appendEvents
131+ , onceE
132+ , sequenceThese
133+ , fmapMaybeCheap
134+ , fmapCheap
135+ , fforCheap
136+ , fforMaybeCheap
137+ , pushAlwaysCheap
138+ , tagCheap
139+ , mergeWithCheap
140+ , mergeWithCheap'
141+ -- * Slow, but general, implementations
142+ , slowHeadE
143+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
144+ , Spider
145+ , SpiderEnv
146+ , SpiderTimeline
147+ , Global
148+ , Behavior (..)
149+ , Event (..)
150+ , Dynamic (..)
151+ , Incremental (..)
152+ , never
153+ , constant
154+ , push
155+ , pushCheap
156+ , pull
157+ , merge
158+ , fan
159+ , switch
160+ , coincidence
161+ , current
162+ , updated
163+ , unsafeBuildDynamic
164+ , unsafeBuildIncremental
165+ , mergeIncremental
166+ , mergeIncrementalWithMove
167+ , currentIncremental
168+ , updatedIncremental
169+ , incrementalToDynamic
170+ , behaviorCoercion
171+ , eventCoercion
172+ , dynamicCoercion
173+#endif
174+ ) where
175+
176+import Control.Applicative
177+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
178+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
179+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
180+import Control.Monad.Trans.Cont (ContT ())
181+import Control.Monad.Trans.Except (ExceptT ())
182+import Control.Monad.Trans.RWS (RWST ())
183+import Control.Monad.Trans.Writer (WriterT ())
184+import Data.Align
185+import Data.Bifunctor
186+import Data.Coerce
187+import Data.Default
188+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
189+import qualified Data.Dependent.Map as DMap
190+import Data.Either
191+import Data.Foldable
192+import Data.Functor.Bind hiding (join)
193+import qualified Data.Functor.Bind as Bind
194+import Data.Functor.Constant
195+import Data.Functor.Misc
196+import Data.Functor.Plus
197+import Data.IntMap.Strict (IntMap)
198+import qualified Data.IntMap.Strict as IntMap
199+import Data.List.NonEmpty (NonEmpty (..))
200+import Data.Map (Map)
201+import Data.Maybe
202+import Data.Monoid hiding (Alt, (<>))
203+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
204+import Data.String
205+import Data.These
206+import Data.Traversable
207+import Data.Type.Coercion
208+import Reflex.FunctorMaybe
209+import Reflex.Patch
210+import Data.FastMutableIntMap (PatchIntMap)
211+
212+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
213+import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),
214+ SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,
215+ dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,
216+ dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,
217+ runFrame, runSpiderHostFrame)
218+import qualified Reflex.Spider.Internal
219+import qualified Reflex.Spider.Internal as S
220+import Unsafe.Coerce
221+#endif
222+
223+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
224+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
225+
226+import Debug.Trace (trace)
227+
228+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
229+#include "Spider/SpiderTimeline.include.hs"
230+#endif
231+
232+-- | The 'Reflex' class contains all the primitive functionality needed for
233+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates
234+-- which "timeline" is in use. Timelines are fully-independent FRP contexts,
235+-- and the type of the timeline determines the FRP engine to be used. For most
236+-- purposes, the 'Reflex.Spider' implementation is recommended.
237+class ( MonadHold t (PushM t)
238+ , MonadSample t (PullM t)
239+ , MonadFix (PushM t)
240+ , Functor (Dynamic t)
241+ , Applicative (Dynamic t) -- Necessary for GHC <= 7.8
242+ , Monad (Dynamic t)
243+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
244+ , t ~ SpiderTimeline Global
245+#endif
246+ ) => Reflex t where
247+ -- | A container for a value that can change over time. 'Behavior's can be
248+ -- sampled at will, but it is not possible to be notified when they change
249+ data Behavior t :: * -> *
250+ -- | A stream of occurrences. During any given frame, an 'Event' is either
251+ -- occurring or not occurring; if it is occurring, it will contain a value of
252+ -- the given type (its "occurrence type")
253+ data Event t :: * -> *
254+ -- | A container for a value that can change over time and allows
255+ -- notifications on changes. Basically a combination of a 'Behavior' and an
256+ -- 'Event', with a rule that the 'Behavior' will change if and only if the
257+ -- 'Event' fires.
258+ data Dynamic t :: * -> *
259+ -- | An 'Incremental' is a more general form of a 'Dynamic'.
260+ -- Instead of always fully replacing the value, only parts of it can be patched.
261+ -- This is only needed for performance critical code via `mergeIncremental` to make small
262+ -- changes to large values.
263+ data Incremental t :: * -> *
264+ -- | A monad for doing complex push-based calculations efficiently
265+ type PushM t :: * -> *
266+ -- | A monad for doing complex pull-based calculations efficiently
267+ type PullM t :: * -> *
268+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
269+ -- | An 'Event' with no occurrences
270+ never :: Event t a
271+ -- | Create a 'Behavior' that always has the given value
272+ 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
273+ -- | Create an 'Event' from another 'Event'; the provided function can sample
274+ -- 'Behavior's and hold 'Event's, and use the results to produce a occurring
275+ -- (Just) or non-occurring (Nothing) result
276+ push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
277+ -- | 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.
278+ pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
279+ -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be
280+ -- recomputed whenever any of the read 'Behavior's changes
281+ pull :: PullM t a -> Behavior t a
282+ -- | Merge a collection of events; the resulting 'Event' will only occur if at
283+ -- least one input event is occuring, and will contain all of the input keys
284+ -- that are occurring simultaneously
285+ 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
286+ -- | Efficiently fan-out an event to many destinations. This function should
287+ -- be partially applied, and then the result applied repeatedly to create
288+ -- child events
289+ 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
290+ -- | Create an 'Event' that will occur whenever the currently-selected input
291+ -- 'Event' occurs
292+ switch :: Behavior t (Event t a) -> Event t a
293+ -- | Create an 'Event' that will occur whenever the input event is occurring
294+ -- and its occurrence value, another 'Event', is also occurring
295+ coincidence :: Event t (Event t a) -> Event t a
296+ -- | Extract the 'Behavior' of a 'Dynamic'.
297+ current :: Dynamic t a -> Behavior t a
298+ -- | Extract the 'Event' of the 'Dynamic'.
299+ updated :: Dynamic t a -> Event t a
300+ -- | Create a new 'Dynamic'. The given 'PullM' must always return the most
301+ -- recent firing of the given 'Event', if any.
302+ unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
303+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change
304+ -- in the same way that the accumulated application of patches would change
305+ -- that value.
306+ unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
307+ -- | Create a merge whose parents can change over time
308+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
309+ -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
310+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
311+ -- | Extract the 'Behavior' component of an 'Incremental'
312+ currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
313+ -- | Extract the 'Event' component of an 'Incremental'
314+ updatedIncremental :: Patch p => Incremental t p -> Event t p
315+ -- | Convert an 'Incremental' to a 'Dynamic'
316+ incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)
317+ -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its
318+ -- occurrence type
319+ behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)
320+ -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its
321+ -- occurrence type
322+ eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)
323+ -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
324+ -- occurrence type
325+ dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
326+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
327+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a
328+#endif
329+
330+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
331+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
332+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
333+
334+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
335+instance t ~ SpiderTimeline Global => Reflex t where
336+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }
337+ newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }
338+ newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Reflex.Spider.Internal.Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)
339+ newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Reflex.Spider.Internal.Dynamic Global p }
340+ type PullM t = SpiderPullM Global
341+ type PushM t = SpiderPushM Global
342+never :: Reflex t => Event t a
343+constant :: Reflex t => a -> Behavior t a
344+push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b
345+pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b
346+pull :: Reflex t => PullM t a -> Behavior t a
347+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
348+fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k
349+switch :: Reflex t => Behavior t (Event t a) -> Event t a
350+coincidence :: Reflex t => Event t (Event t a) -> Event t a
351+current :: Reflex t => Dynamic t a -> Behavior t a
352+updated :: Reflex t => Dynamic t a -> Event t a
353+unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a
354+unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p
355+mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
356+mergeIncrementalWithMove :: (Reflex t, GCompare k) => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
357+currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)
358+updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p
359+incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)
360+behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)
361+eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)
362+dynamicCoercion :: Reflex t => Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
363+{-# INLINE never #-}
364+never = SpiderEvent S.eventNever
365+{-# INLINE constant #-}
366+constant = SpiderBehavior . S.behaviorConst
367+{-# INLINE push #-}
368+push f = SpiderEvent . S.push (coerce f) . unSpiderEvent
369+{-# INLINE pushCheap #-}
370+pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent
371+{-# INLINE pull #-}
372+pull = SpiderBehavior . S.pull . coerce
373+{-# INLINE merge #-}
374+merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))
375+{-# INLINE fan #-}
376+fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))
377+{-# INLINE switch #-}
378+switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior
379+{-# INLINE coincidence #-}
380+coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent
381+{-# INLINE current #-}
382+current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic
383+{-# INLINE updated #-}
384+updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic
385+{-# INLINE unsafeBuildDynamic #-}
386+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
387+{-# INLINE unsafeBuildIncremental #-}
388+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ S.unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
389+{-# INLINE mergeIncremental #-}
390+mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental
391+{-# INLINE mergeIncrementalWithMove #-}
392+mergeIncrementalWithMove = SpiderEvent . S.mergeWithMove . (unsafeCoerce :: S.Dynamic x (PatchDMapWithMove k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMapWithMove k (S.Event x))) . unSpiderIncremental
393+{-# INLINE currentIncremental #-}
394+currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
395+{-# INLINE updatedIncremental #-}
396+updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
397+{-# INLINE incrementalToDynamic #-}
398+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do
399+ c <- readBehaviorUntracked $ dynamicCurrent i
400+ return $ Identity <$> apply p c
401+eventCoercion Coercion = Coercion
402+behaviorCoercion Coercion = Coercion
403+dynamicCoercion = unsafeCoerce
404+#endif
405+
406+-- | Coerce a 'Behavior' between representationally-equivalent value types
407+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b
408+coerceBehavior = coerceWith $ behaviorCoercion Coercion
409+
410+-- | Coerce an 'Event' between representationally-equivalent occurrence types
411+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b
412+coerceEvent = coerceWith $ eventCoercion Coercion
413+
414+-- | Coerce a 'Dynamic' between representationally-equivalent value types
415+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
416+coerceDynamic = coerceWith $ dynamicCoercion Coercion
417+
418+-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
419+-- _must_ change when and only when the 'Event' fires, such that the
420+-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
421+-- if this is not the case, the resulting 'Dynamic' will behave
422+-- nondeterministically.
423+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
424+unsafeDynamic = unsafeBuildDynamic . sample
425+
426+-- | Construct a 'Dynamic' value that never changes
427+constDyn :: Reflex t => a -> Dynamic t a
428+constDyn = pure
429+
430+instance (Reflex t, Default a) => Default (Dynamic t a) where
431+ def = pure def
432+
433+-- | 'MonadSample' designates monads that can read the current value of a
434+-- 'Behavior'. This includes both 'PullM' and 'PushM'.
435+class (Applicative m, Monad m) => MonadSample t m | m -> t where
436+ -- | Get the current value in the 'Behavior'
437+ sample :: Behavior t a -> m a
438+
439+-- | 'MonadHold' designates monads that can create new 'Behavior's based on
440+-- 'Event's; usually this will be 'PushM' or a monad based on it. 'MonadHold'
441+-- is required to create any stateful computations with Reflex.
442+class MonadSample t m => MonadHold t m where
443+ -- | Create a new 'Behavior' whose value will initially be equal to the given
444+ -- value and will be updated whenever the given 'Event' occurs. The update
445+ -- takes effect immediately after the 'Event' occurs; if the occurrence that
446+ -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample
447+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new
448+ -- one.
449+ hold :: a -> Event t a -> m (Behavior t a)
450+ default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)
451+ hold v0 = lift . hold v0
452+ -- | Create a 'Dynamic' value using the given initial value that changes every
453+ -- time the 'Event' occurs.
454+ holdDyn :: a -> Event t a -> m (Dynamic t a)
455+ default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)
456+ holdDyn v0 = lift . holdDyn v0
457+ -- | Create an 'Incremental' value using the given initial value that changes
458+ -- every time the 'Event' occurs.
459+ holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
460+ default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
461+ holdIncremental v0 = lift . holdIncremental v0
462+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)
463+ {-
464+ default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
465+ buildDynamic getV0 = lift . buildDynamic getV0
466+ -}
467+ -- | Create a new 'Event' that only occurs only once, on the first occurence of
468+ -- the supplied 'Event'.
469+ headE :: Event t a -> m (Event t a)
470+
471+
472+slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
473+slowHeadE e = do
474+ rec be <- hold e $ fmapCheap (const never) e'
475+ let e' = switch be
476+ return e'
477+
478+-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a
479+-- key. This is much more efficient than filtering for each key with
480+-- 'fmapMaybe'.
481+newtype EventSelector t k = EventSelector
482+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
483+ -- determined by the type of the key, so this can be used to fan-out
484+ -- 'Event's whose sub-'Event's have different types.
485+ --
486+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
487+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant
488+ -- occurrences of an 'Event'.
489+ select :: forall a. k a -> Event t a
490+ }
491+
492+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
493+
494+--------------------------------------------------------------------------------
495+-- Instances
496+--------------------------------------------------------------------------------
497+
498+instance MonadSample t m => MonadSample t (ReaderT r m) where
499+ sample = lift . sample
500+
501+instance MonadHold t m => MonadHold t (ReaderT r m) where
502+ hold a0 = lift . hold a0
503+ holdDyn a0 = lift . holdDyn a0
504+ holdIncremental a0 = lift . holdIncremental a0
505+ buildDynamic a0 = lift . buildDynamic a0
506+ headE = lift . headE
507+
508+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
509+ sample = lift . sample
510+
511+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
512+ hold a0 = lift . hold a0
513+ holdDyn a0 = lift . holdDyn a0
514+ holdIncremental a0 = lift . holdIncremental a0
515+ buildDynamic a0 = lift . buildDynamic a0
516+ headE = lift . headE
517+
518+instance MonadSample t m => MonadSample t (StateT s m) where
519+ sample = lift . sample
520+
521+instance MonadHold t m => MonadHold t (StateT s m) where
522+ hold a0 = lift . hold a0
523+ holdDyn a0 = lift . holdDyn a0
524+ holdIncremental a0 = lift . holdIncremental a0
525+ buildDynamic a0 = lift . buildDynamic a0
526+ headE = lift . headE
527+
528+instance MonadSample t m => MonadSample t (ExceptT e m) where
529+ sample = lift . sample
530+
531+instance MonadHold t m => MonadHold t (ExceptT e m) where
532+ hold a0 = lift . hold a0
533+ holdDyn a0 = lift . holdDyn a0
534+ holdIncremental a0 = lift . holdIncremental a0
535+ buildDynamic a0 = lift . buildDynamic a0
536+ headE = lift . headE
537+
538+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
539+ sample = lift . sample
540+
541+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
542+ hold a0 = lift . hold a0
543+ holdDyn a0 = lift . holdDyn a0
544+ holdIncremental a0 = lift . holdIncremental a0
545+ buildDynamic a0 = lift . buildDynamic a0
546+ headE = lift . headE
547+
548+instance MonadSample t m => MonadSample t (ContT r m) where
549+ sample = lift . sample
550+
551+instance MonadHold t m => MonadHold t (ContT r m) where
552+ hold a0 = lift . hold a0
553+ holdDyn a0 = lift . holdDyn a0
554+ holdIncremental a0 = lift . holdIncremental a0
555+ buildDynamic a0 = lift . buildDynamic a0
556+ headE = lift . headE
557+
558+--------------------------------------------------------------------------------
559+-- Convenience functions
560+--------------------------------------------------------------------------------
561+
562+-- | Create an 'Event' from another 'Event'. The provided function can sample
563+-- 'Behavior's and hold 'Event's.
564+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
565+pushAlways f = push (fmap Just . f)
566+
567+-- | Flipped version of 'fmap'.
568+ffor :: Functor f => f a -> (a -> b) -> f b
569+ffor = flip fmap
570+
571+instance Reflex t => Applicative (Behavior t) where
572+ pure = constant
573+ f <*> x = pull $ sample f `ap` sample x
574+ _ *> b = b
575+ a <* _ = a
576+
577+instance Reflex t => Apply (Behavior t) where
578+ (<.>) = (<*>)
579+
580+instance Reflex t => Bind (Behavior t) where
581+ (>>-) = (>>=)
582+
583+instance (Reflex t, Fractional a) => Fractional (Behavior t a) where
584+ (/) = liftA2 (/)
585+ fromRational = pure . fromRational
586+ recip = fmap recip
587+
588+instance Reflex t => Functor (Behavior t) where
589+ fmap f = pull . fmap f . sample
590+
591+instance (Reflex t, IsString a) => IsString (Behavior t a) where
592+ fromString = pure . fromString
593+
594+instance Reflex t => Monad (Behavior t) where
595+ a >>= f = pull $ sample a >>= sample . f
596+ -- 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.
597+ return = constant
598+ fail = error "Monad (Behavior t) does not support fail"
599+
600+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
601+ mempty = constant mempty
602+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
603+ mconcat = pull . fmap mconcat . mapM sample
604+
605+instance (Reflex t, Num a) => Num (Behavior t a) where
606+ (+) = liftA2 (+)
607+ (-) = liftA2 (-)
608+ (*) = liftA2 (*)
609+ abs = fmap abs
610+ fromInteger = pure . fromInteger
611+ negate = fmap negate
612+ signum = fmap signum
613+
614+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
615+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
616+ sconcat = pull . fmap sconcat . mapM sample
617+#if MIN_VERSION_semigroups(0,17,0)
618+ stimes n = fmap $ stimes n
619+#else
620+ times1p n = fmap $ times1p n
621+#endif
622+
623+-- | Flipped version of 'fmapMaybe'.
624+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
625+fforMaybe = flip fmapMaybe
626+
627+-- | Filter 'f a' using the provided predicate.
628+-- Relies on 'fforMaybe'.
629+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
630+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
631+
632+-- | Filter 'Left's from 'f (Either a b)' into 'a'.
633+filterLeft :: FunctorMaybe f => f (Either a b) -> f a
634+filterLeft = fmapMaybe (either Just (const Nothing))
635+
636+-- | Filter 'Right's from 'f (Either a b)' into 'b'.
637+filterRight :: FunctorMaybe f => f (Either a b) -> f b
638+filterRight = fmapMaybe (either (const Nothing) Just)
639+
640+-- | Left-biased event union (prefers left event on simultaneous
641+-- occurrence).
642+instance Reflex t => Alt (Event t) where
643+ ev1 <!> ev2 = leftmost [ev1, ev2]
644+
645+-- | 'Event' intersection (convenient interface to 'coincidence').
646+instance Reflex t => Apply (Event t) where
647+ evf <.> evx = coincidence (fmap (<$> evx) evf)
648+
649+-- | 'Event' intersection (convenient interface to 'coincidence').
650+instance Reflex t => Bind (Event t) where
651+ evx >>- f = coincidence (f <$> evx)
652+ join = coincidence
653+
654+instance Reflex t => Functor (Event t) where
655+ {-# INLINE fmap #-}
656+ fmap f = fmapMaybe $ Just . f
657+ {-# INLINE (<$) #-}
658+ x <$ e = fmapCheap (const x) e
659+
660+instance Reflex t => FunctorMaybe (Event t) where
661+ {-# INLINE fmapMaybe #-}
662+ fmapMaybe f = push $ return . f
663+
664+-- | Never: @'zero' = 'never'@.
665+instance Reflex t => Plus (Event t) where
666+ zero = never
667+
668+-- | Replace each occurrence value of the 'Event' with the value of the
669+-- 'Behavior' at the time of that occurrence.
670+tag :: Reflex t => Behavior t b -> Event t a -> Event t b
671+tag b = pushAlways $ \_ -> sample b
672+
673+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the
674+-- current value of the 'Behavior'.
675+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
676+attach = attachWith (,)
677+
678+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by
679+-- combining it with the current value of the 'Behavior'.
680+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
681+attachWith f = attachWithMaybe $ \a b -> Just $ f a b
682+
683+-- | Create a new 'Event' by combining each occurence with the current value of
684+-- the 'Behavior'. The occurrence is discarded if the combining function returns
685+-- Nothing
686+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
687+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
688+
689+-- | Create a new 'Event' that occurs on all but the first occurence of the
690+-- supplied 'Event'.
691+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
692+tailE e = snd <$> headTailE e
693+
694+-- | Create a tuple of two 'Event's with the first one occuring only the first
695+-- time the supplied 'Event' occurs and the second occuring on all but the first
696+-- occurence.
697+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
698+headTailE e = do
699+ eHead <- headE e
700+ be <- hold never $ fmap (const e) eHead
701+ return (eHead, switch be)
702+
703+-- | Starting at the current time, fire all the occurrences of the 'Event' for
704+-- which the given predicate returns 'True'. When 'False' is returned, do not
705+-- fire, and permanently stop firing, even if 'True' values are encountered
706+-- later.
707+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)
708+takeWhileE f e = do
709+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a
710+ then Right a
711+ else Left never
712+ be <- hold e eFalse
713+ let e' = switch be
714+ return eTrue
715+
716+-- | Split the supplied 'Event' into two individual 'Event's occuring at the
717+-- same time with the respective values from the tuple.
718+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
719+splitE e = (fmap fst e, fmap snd e)
720+
721+-- | Print the supplied 'String' and the value of the 'Event' on each
722+-- occurence. This should /only/ be used for debugging.
723+--
724+-- Note: As with Debug.Trace.trace, the message will only be printed if the
725+-- 'Event' is actually used.
726+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
727+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
728+
729+-- | Print the output of the supplied function on each occurence of the
730+-- 'Event'. This should /only/ be used for debugging.
731+--
732+-- Note: As with Debug.Trace.trace, the message will only be printed if the
733+-- 'Event' is actually used.
734+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
735+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
736+
737+instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
738+ (<>) = alignWith (mergeThese (<>))
739+ sconcat = fmap sconcat . mergeList . toList
740+#if MIN_VERSION_semigroups(0,17,0)
741+ stimes n = fmap $ stimes n
742+#else
743+ times1p n = fmap $ times1p n
744+#endif
745+
746+instance (Semigroup a, Reflex t) => Monoid (Event t a) where
747+ mempty = never
748+ mappend = (<>)
749+ mconcat = fmap sconcat . mergeList
750+
751+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
752+-- list occurs. If multiple occur at the same time they are folded from the left
753+-- with the given function.
754+{-# INLINE mergeWith #-}
755+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
756+mergeWith = mergeWith' id
757+
758+{-# INLINE mergeWith' #-}
759+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
760+mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)
761+ . mergeInt
762+ . IntMap.fromDistinctAscList
763+ $ zip [0 :: Int ..] es
764+
765+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
766+-- list occurs. If multiple occur at the same time the value is the value of the
767+-- leftmost event.
768+{-# INLINE leftmost #-}
769+leftmost :: Reflex t => [Event t a] -> Event t a
770+leftmost = mergeWith const
771+
772+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
773+-- list occurs and has a list of the values of all 'Event's occuring at that
774+-- time.
775+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
776+mergeList [] = never
777+mergeList es = mergeWithFoldCheap' id es
778+
779+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
780+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
781+
782+-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
783+-- occurs if at least one of them occurs and has a map of values of all 'Event's
784+-- occuring at that time.
785+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
786+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
787+
788+-- | Create a merge whose parents can change over time
789+mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
790+mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
791+
792+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
793+mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)
794+mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)
795+
796+-- | Split the event into separate events for 'Left' and 'Right' values.
797+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)
798+fanEither e =
799+ let justLeft = either Just (const Nothing)
800+ justRight = either (const Nothing) Just
801+ in (fmapMaybe justLeft e, fmapMaybe justRight e)
802+
803+-- | Split the event into separate events for 'This' and 'That' values,
804+-- allowing them to fire simultaneously when the input value is 'These'.
805+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)
806+fanThese e =
807+ let this (This x) = Just x
808+ this (These x _) = Just x
809+ this _ = Nothing
810+ that (That y) = Just y
811+ that (These _ y) = Just y
812+ that _ = Nothing
813+ in (fmapMaybe this e, fmapMaybe that e)
814+
815+-- | Split the event into an 'EventSelector' that allows efficient selection of
816+-- the individual 'Event's.
817+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
818+fanMap = fan . fmap mapToDMap
819+
820+-- | Switches to the new event whenever it receives one. Whenever a new event
821+-- is provided, if it is firing, its value will be the resulting event's value;
822+-- if it is not firing, but the old one is, the old one's value will be used.
823+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
824+switchPromptly ea0 eea = do
825+ bea <- hold ea0 eea
826+ let eLag = switch bea
827+ eCoincidences = coincidence eea
828+ return $ leftmost [eCoincidences, eLag]
829+
830+-- | 'switch'es to a new event whenever it receives one. At the moment of
831+-- switching, the old event will be ignored if it fires, and the new one will be
832+-- used if it fires; this is the opposite of 'switch', which will use only the
833+-- old value.
834+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
835+switchPromptOnly e0 e' = do
836+ eLag <- switch <$> hold e0 e'
837+ return $ coincidence $ leftmost [e', eLag <$ eLag]
838+
839+instance Reflex t => Align (Event t) where
840+ nil = never
841+ align = alignEventWithMaybe Just
842+
843+-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
844+-- the 'Behavior' is true at the time of occurence.
845+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
846+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
847+
848+-- | Create a new behavior given a starting behavior and switch to a the behvior
849+-- carried by the event when it fires.
850+switcher :: (Reflex t, MonadHold t m)
851+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
852+switcher b eb = pull . (sample <=< sample) <$> hold b eb
853+
854+instance (Reflex t, IsString a) => IsString (Dynamic t a) where
855+ fromString = pure . fromString
856+
857+-- | Combine two 'Dynamic's. The result will change whenever either (or both)
858+-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.
859+zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)
860+zipDyn = zipDynWith (,)
861+
862+-- | Combine two 'Dynamic's with a combining function. The result will change
863+-- whenever either (or both) input 'Dynamic' changes.
864+-- More efficient than liftA2.
865+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
866+zipDynWith f da db =
867+ let eab = align (updated da) (updated db)
868+ ec = flip push eab $ \o -> do
869+ (a, b) <- case o of
870+ This a -> do
871+ b <- sample $ current db
872+ return (a, b)
873+ That b -> do
874+ a <- sample $ current da
875+ return (a, b)
876+ These a b -> return (a, b)
877+ return $ Just $ f a b
878+ in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
879+
880+instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
881+ mconcat = distributeListOverDynWith mconcat
882+ mempty = constDyn mempty
883+ mappend = zipDynWith mappend
884+
885+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
886+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
887+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.
888+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
889+distributeDMapOverDynPure dm = case DMap.toList dm of
890+ [] -> constDyn DMap.empty
891+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
892+ _ ->
893+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
894+ edmPre = merge $ DMap.map updated dm
895+ result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
896+ olds <- sample $ current result
897+ return $ DMap.unionWithKey (\_ _ new -> new) olds news
898+ in result
899+
900+-- | Convert a list of 'Dynamic's into a 'Dynamic' list.
901+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
902+distributeListOverDyn = distributeListOverDynWith id
903+
904+-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
905+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b
906+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
907+
908+-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
909+-- unless the second supplied 'Event' occurs simultaneously.
910+difference :: Reflex t => Event t a -> Event t b -> Event t a
911+difference = alignEventWithMaybe $ \case
912+ This a -> Just a
913+ _ -> Nothing
914+
915+alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c
916+alignEventWithMaybe f ea eb =
917+ fmapMaybe (f <=< dmapToThese)
918+ $ merge
919+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
920+
921+
922+--------------------------------------------------------------------------------
923+-- Accumulator
924+--------------------------------------------------------------------------------
925+
926+-- | An 'Accumulator' type can be built by accumulating occurrences of an
927+-- 'Event'.
928+#if __GLASGOW_HASKELL__ < 802
929+{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
930+{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
931+{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
932+{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
933+#endif
934+class Reflex t => Accumulator t f | f -> t where
935+ accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
936+ accum f = accumMaybe $ \v o -> Just $ f v o
937+ accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
938+ accumM f = accumMaybeM $ \v o -> Just <$> f v o
939+ accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
940+ accumMaybe f = accumMaybeM $ \v o -> return $ f v o
941+ accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
942+ mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
943+ mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
944+ mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
945+ mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
946+ mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
947+ mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
948+ mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
949+
950+accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)
951+accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o
952+accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)
953+accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o
954+accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)
955+accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o
956+accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
957+accumMaybeMDyn f z e = do
958+ rec let e' = flip push e $ \o -> do
959+ v <- sample $ current d'
960+ f v o
961+ d' <- holdDyn z e'
962+ return d'
963+mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
964+mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o
965+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)
966+mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o
967+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)
968+mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o
969+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)
970+mapAccumMaybeMDyn f z e = do
971+ rec let e' = flip push e $ \o -> do
972+ v <- sample $ current d'
973+ result <- f v o
974+ return $ case result of
975+ (Nothing, Nothing) -> Nothing
976+ _ -> Just result
977+ d' <- holdDyn z $ fmapMaybe fst e'
978+ return (d', fmapMaybe snd e')
979+
980+{-# INLINE accumB #-}
981+accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)
982+accumB f = accumMaybeB $ \v o -> Just $ f v o
983+{-# INLINE accumMB #-}
984+accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)
985+accumMB f = accumMaybeMB $ \v o -> Just <$> f v o
986+{-# INLINE accumMaybeB #-}
987+accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)
988+accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o
989+{-# INLINE accumMaybeMB #-}
990+accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)
991+accumMaybeMB f z e = do
992+ rec let e' = flip push e $ \o -> do
993+ v <- sample d'
994+ f v o
995+ d' <- hold z e'
996+ return d'
997+{-# INLINE mapAccumB #-}
998+mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
999+mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o
1000+{-# INLINE mapAccumMB #-}
1001+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)
1002+mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o
1003+{-# INLINE mapAccumMaybeB #-}
1004+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)
1005+mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o
1006+
1007+{-# INLINE mapAccumMaybeMB #-}
1008+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)
1009+mapAccumMaybeMB f z e = do
1010+ rec let e' = flip push e $ \o -> do
1011+ v <- sample d'
1012+ result <- f v o
1013+ return $ case result of
1014+ (Nothing, Nothing) -> Nothing
1015+ _ -> Just result
1016+ d' <- hold z $ fmapMaybe fst e'
1017+ return (d', fmapMaybe snd e')
1018+
1019+-- | Accumulate occurrences of an 'Event', producing an output occurrence each
1020+-- time. Discard the underlying 'Accumulator'.
1021+{-# INLINE mapAccum_ #-}
1022+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)
1023+mapAccum_ f z e = do
1024+ (_, result) <- mapAccumB f z e
1025+ return result
1026+
1027+-- | Accumulate occurrences of an 'Event', possibly producing an output
1028+-- occurrence each time. Discard the underlying 'Accumulator'.
1029+{-# INLINE mapAccumMaybe_ #-}
1030+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)
1031+mapAccumMaybe_ f z e = do
1032+ (_, result) <- mapAccumMaybeB f z e
1033+ return result
1034+
1035+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing
1036+-- an output occurrence each time. Discard the underlying 'Accumulator'.
1037+{-# INLINE mapAccumM_ #-}
1038+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)
1039+mapAccumM_ f z e = do
1040+ (_, result) <- mapAccumMB f z e
1041+ return result
1042+
1043+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly
1044+-- producing an output occurrence each time. Discard the underlying
1045+-- 'Accumulator'.
1046+{-# INLINE mapAccumMaybeM_ #-}
1047+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)
1048+mapAccumMaybeM_ f z e = do
1049+ (_, result) <- mapAccumMaybeMB f z e
1050+ return result
1051+
1052+instance Reflex t => Accumulator t (Dynamic t) where
1053+ accumMaybeM = accumMaybeMDyn
1054+ mapAccumMaybeM = mapAccumMaybeMDyn
1055+
1056+instance Reflex t => Accumulator t (Behavior t) where
1057+ accumMaybeM = accumMaybeMB
1058+ mapAccumMaybeM = mapAccumMaybeMB
1059+
1060+instance Reflex t => Accumulator t (Event t) where
1061+ accumMaybeM f z e = updated <$> accumMaybeM f z e
1062+ mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
1063+
1064+-- | Create a new 'Event' by combining each occurence with the next value of the
1065+-- list using the supplied function. If the list runs out of items, all
1066+-- subsequent 'Event' occurrences will be ignored.
1067+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
1068+zipListWithEvent f l e = do
1069+ let f' a b = case a of
1070+ h:t -> (Just t, Just $ f h b)
1071+ _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
1072+ mapAccumMaybe_ f' l e
1073+
1074+-- | Assign a number to each occurence of the given 'Event', starting from 0
1075+{-# INLINE numberOccurrences #-}
1076+numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))
1077+numberOccurrences = numberOccurrencesFrom 0
1078+
1079+-- | Assign a number to each occurence of the given 'Event'
1080+{-# INLINE numberOccurrencesFrom #-}
1081+numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))
1082+numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))
1083+
1084+-- | Assign a number to each occurence of the given 'Event'; discard the occurrences' values
1085+{-# INLINE numberOccurrencesFrom_ #-}
1086+numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)
1087+numberOccurrencesFrom_ = mapAccum_ (\n _ -> (n + 1, n))
1088+
1089+-- | This is used to sample the value of a 'Behavior' using an 'Event'.
1090+--
1091+-- The '<@>' operator is intended to be used in conjunction with
1092+-- the 'Applicative' instance for 'Behavior'.
1093+--
1094+-- This is useful when we want to combine the values of one 'Event' and
1095+-- the value of several 'Behavior's at the time the 'Event' is firing.
1096+--
1097+-- If we have:
1098+--
1099+-- > f :: a -> b -> c -> d
1100+-- > b1 :: Behavior t a
1101+-- > b2 :: Behavior t b
1102+-- > e :: Event t c
1103+--
1104+-- then we can do:
1105+--
1106+-- > f <$> b1 <*> b2 <@> e :: Event t d
1107+--
1108+-- in order to apply the function 'f' to the relevant values.
1109+--
1110+-- The alternative would be something like:
1111+--
1112+-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d
1113+--
1114+-- or a variation involing a custom data type to hold the combination of
1115+-- 'Behavior's even when that combination might only ever be used by 'f'.
1116+--
1117+-- A more suggestive example might be:
1118+--
1119+-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)
1120+--
1121+(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b
1122+(<@>) b = push $ \x -> do
1123+ f <- sample b
1124+ return . Just . f $ x
1125+infixl 4 <@>
1126+
1127+-- | An version of '<@>' that does not use the value of the 'Event'.
1128+--
1129+-- Alternatively, it is 'tag' in operator form.
1130+--
1131+-- This is useful when we want to combine the values of several
1132+-- 'Behavior's at particular points in time using an 'Applicative'
1133+-- style syntax.
1134+--
1135+-- If we have:
1136+--
1137+-- > g :: a -> b -> d
1138+-- > b1 :: Behavior t a
1139+-- > b2 :: Behavior t b
1140+-- > e :: Event t c
1141+--
1142+-- where 'e' is firing at the points in time of interest.
1143+--
1144+-- Then we can use '<@':
1145+--
1146+-- > g <$> b1 <*> b2 <@ e :: Event t d
1147+--
1148+-- to combine the values of 'b1' and 'b2' at each of those points of time,
1149+-- with the function 'g' being used to combine the values.
1150+--
1151+-- This is the same as '<@>' except that the 'Event' is being used only
1152+-- to act as a trigger.
1153+(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b
1154+(<@) = tag
1155+infixl 4 <@
1156+
1157+-- | A 'Monad' that supports adjustment over time. After an action has been
1158+-- run, if the given events fire, it will adjust itself so that its net effect
1159+-- is as though it had originally been run with the new value. Note that there
1160+-- is some issue here with persistent side-effects: obviously, IO (and some
1161+-- other side-effects) cannot be undone, so it is up to the instance implementer
1162+-- to determine what the best meaning for this class is in such cases.
1163+class (Reflex t, Monad m) => MonadAdjust t m | m -> t where
1164+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
1165+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
1166+ 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'))
1167+ 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'))
1168+
1169+instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where
1170+ runWithReplace a0 a' = do
1171+ r <- ask
1172+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
1173+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
1174+ r <- ask
1175+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1176+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
1177+ r <- ask
1178+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1179+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
1180+ r <- ask
1181+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
1182+
1183+sequenceDMapWithAdjust :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
1184+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
1185+
1186+sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
1187+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
1188+
1189+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'))
1190+mapMapWithAdjustWithMove f m0 m' = do
1191+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
1192+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
1193+
1194+------------------
1195+-- Cheap Functions
1196+------------------
1197+
1198+{-# INLINE pushAlwaysCheap #-}
1199+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
1200+pushAlwaysCheap f = pushCheap (fmap Just . f)
1201+
1202+{-# INLINE fmapMaybeCheap #-}
1203+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1204+fmapMaybeCheap f = pushCheap $ return . f
1205+
1206+{-# INLINE fforMaybeCheap #-}
1207+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b
1208+fforMaybeCheap = flip fmapMaybeCheap
1209+
1210+{-# INLINE fforCheap #-}
1211+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b
1212+fforCheap = flip fmapCheap
1213+
1214+{-# INLINE fmapCheap #-}
1215+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b
1216+fmapCheap f = pushCheap $ return . Just . f
1217+
1218+{-# INLINE tagCheap #-}
1219+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1220+tagCheap b = pushAlwaysCheap $ \_ -> sample b
1221+
1222+{-# INLINE mergeWithCheap #-}
1223+mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1224+mergeWithCheap = mergeWithCheap' id
1225+
1226+{-# INLINE mergeWithCheap' #-}
1227+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
1228+mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f
1229+
1230+{-# INLINE mergeWithFoldCheap' #-}
1231+mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b
1232+mergeWithFoldCheap' f es =
1233+ fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)
1234+ . mergeInt
1235+ . IntMap.fromDistinctAscList
1236+ $ zip [0 :: Int ..] es
1237+
1238+--------------------------------------------------------------------------------
1239+-- Deprecated functions
1240+--------------------------------------------------------------------------------
1241+
1242+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's
1243+-- occurs. If both occur at the same time they are combined using 'mappend'.
1244+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}
1245+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
1246+appendEvents = alignWith $ mergeThese mappend
1247+
1248+-- | Alias for 'headE'
1249+{-# DEPRECATED onceE "Use 'headE' instead" #-}
1250+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
1251+onceE = headE
1252+
1253+-- | Run both sides of a 'These' monadically, combining the results.
1254+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
1255+#ifdef USE_TEMPLATE_HASKELL
1256+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}
1257+#endif
1258+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
1259+sequenceThese t = case t of
1260+ This ma -> fmap This ma
1261+ These ma mb -> liftM2 These ma mb
1262+ 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 pushCheap (updated d) $ \new -> do
35+ old <- sample $ current d --TODO: Is it better to sample ourselves here?
36+ return $ unsafeJustChanged old new
37+
38+-- | Retrieve a normal 'Dynamic' from a 'UniqDynamic'. This will perform a
39+-- final check using the output type's 'Eq' instance to ensure deterministic
40+-- behavior.
41+--
42+-- WARNING: If used with a type whose 'Eq' instance is not law-abiding -
43+-- specifically, if there are cases where @x /= x@, 'fromUniqDynamic' may
44+-- eliminate more 'updated' occurrences than it should. For example, NaN values
45+-- of 'Double' and 'Float' are considered unequal to themselves by the 'Eq'
46+-- instance, but can be equal by pointer equality. This may cause 'UniqDynamic'
47+-- to lose changes from NaN to NaN.
48+fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a
49+fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e'
50+ where
51+ -- Only consider values different if they fail both pointer equality /and/
52+ -- 'Eq' equality. This is to make things a bit more deterministic in the
53+ -- case of unlawful 'Eq' instances. However, it is still possible to
54+ -- achieve nondeterminism by constructing elements that are identical in
55+ -- value, unequal according to 'Eq', and nondeterministically equal or
56+ -- nonequal by pointer quality. I suspect that it is impossible to make the
57+ -- behavior deterministic in this case.
58+ superEq a b = a `unsafePtrEq` b || a == b
59+ e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d)
60+
61+-- | Create a UniqDynamic without uniqing it on creation. This will be slightly
62+-- faster than uniqDynamic when used with a Dynamic whose values are always (or
63+-- nearly always) different from its previous values; if used with a Dynamic
64+-- whose values do not change frequently, it may be much slower than uniqDynamic
65+alreadyUniqDynamic :: Dynamic t a -> UniqDynamic t a
66+alreadyUniqDynamic = UniqDynamic
67+
68+unsafePtrEq :: a -> a -> Bool
69+unsafePtrEq a b = case a `seq` b `seq` reallyUnsafePtrEquality# a b of
70+ 0# -> False
71+ _ -> True
72+
73+unsafeJustChanged :: a -> a -> Maybe a
74+unsafeJustChanged old new =
75+ if old `unsafePtrEq` new
76+ then Nothing
77+ else Just new
78+
79+instance Reflex t => Accumulator t (UniqDynamic t) where
80+ accumMaybeM f z e = do
81+ let f' old change = do
82+ mNew <- f old change
83+ return $ unsafeJustChanged old =<< mNew
84+ d <- accumMaybeMDyn f' z e
85+ return $ UniqDynamic d
86+ mapAccumMaybeM f z e = do
87+ let f' old change = do
88+ (mNew, output) <- f old change
89+ return (unsafeJustChanged old =<< mNew, output)
90+ (d, out) <- mapAccumMaybeMDyn f' z e
91+ return (UniqDynamic d, out)
92+
93+instance Reflex t => Functor (UniqDynamic t) where
94+ fmap f (UniqDynamic d) = uniqDynamic $ fmap f d
95+
96+instance Reflex t => Applicative (UniqDynamic t) where
97+ pure = UniqDynamic . constDyn
98+ UniqDynamic a <*> UniqDynamic b = uniqDynamic $ a <*> b
99+ _ *> b = b
100+ a <* _ = a
101+
102+instance Reflex t => Monad (UniqDynamic t) where
103+ UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f
104+ _ >> b = b
105+ return = pure
src/Reflex/DynamicWriter.hsnew file+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+283
@@ -0,0 +1,283 @@
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+ , withEventWriterT
24+ ) where
25+
26+import Reflex.Class
27+import Reflex.Host.Class
28+import Reflex.PerformEvent.Class
29+import Reflex.PostBuild.Class
30+import Reflex.Query.Class
31+import Reflex.Requester.Class
32+import Reflex.TriggerEvent.Class
33+
34+import Control.Monad.Exception
35+import Control.Monad.Identity
36+import Control.Monad.Reader
37+import Control.Monad.Ref
38+import Control.Monad.State.Strict
39+import Data.Dependent.Map (DMap, DSum (..))
40+import qualified Data.Dependent.Map as DMap
41+import Data.FastMutableIntMap
42+import Data.Foldable
43+import Data.Functor.Compose
44+import Data.Functor.Misc
45+import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
46+import Data.IntMap.Strict (IntMap)
47+import qualified Data.IntMap.Strict as IntMap
48+import Data.List.NonEmpty (NonEmpty (..))
49+import Data.Map (Map)
50+import Data.Semigroup
51+import Data.Some (Some)
52+import Data.Tuple
53+import Data.Type.Equality
54+
55+import Unsafe.Coerce
56+
57+-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
58+-- and combines them monoidally to provide an 'Event' result.
59+class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
60+ tellEvent :: Event t w -> m ()
61+
62+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
63+newtype TellId w x
64+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
65+ deriving (Show, Eq, Ord, Enum)
66+
67+tellId :: Int -> TellId w w
68+tellId = TellId
69+{-# INLINE tellId #-}
70+
71+tellIdRefl :: TellId w x -> w :~: x
72+tellIdRefl _ = unsafeCoerce Refl
73+
74+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
75+withTellIdRefl tid r = case tellIdRefl tid of
76+ Refl -> r
77+
78+instance GEq (TellId w) where
79+ a `geq` b =
80+ withTellIdRefl a $
81+ withTellIdRefl b $
82+ if a == b
83+ then Just Refl
84+ else Nothing
85+
86+instance GCompare (TellId w) where
87+ a `gcompare` b =
88+ withTellIdRefl a $
89+ withTellIdRefl b $
90+ case a `compare` b of
91+ LT -> GLT
92+ EQ -> GEQ
93+ GT -> GGT
94+
95+data EventWriterState t w = EventWriterState
96+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
97+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
98+ }
99+
100+-- | A basic implementation of 'EventWriter'.
101+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
102+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
103+
104+-- | Run a 'EventWriterT' action.
105+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
106+runEventWriterT (EventWriterT a) = do
107+ (result, requests) <- runStateT a $ EventWriterState (-1) []
108+ let combineResults :: DMap (TellId w) Identity -> w
109+ combineResults = sconcat
110+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
111+ . 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
112+ 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
113+
114+instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
115+ tellEvent w = EventWriterT $ modify $ \old ->
116+ let myId = _eventWriterState_nextId old
117+ in EventWriterState
118+ { _eventWriterState_nextId = pred myId
119+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
120+ }
121+
122+instance EventWriter t w m => EventWriter t w (ReaderT r m) where
123+ tellEvent = lift . tellEvent
124+
125+instance MonadTrans (EventWriterT t w) where
126+ lift = EventWriterT . lift
127+
128+instance MonadSample t m => MonadSample t (EventWriterT t w m) where
129+ sample = lift . sample
130+
131+instance MonadHold t m => MonadHold t (EventWriterT t w m) where
132+ {-# INLINABLE hold #-}
133+ hold v0 = lift . hold v0
134+ {-# INLINABLE holdDyn #-}
135+ holdDyn v0 = lift . holdDyn v0
136+ {-# INLINABLE holdIncremental #-}
137+ holdIncremental v0 = lift . holdIncremental v0
138+ {-# INLINABLE buildDynamic #-}
139+ buildDynamic a0 = lift . buildDynamic a0
140+ {-# INLINABLE headE #-}
141+ headE = lift . headE
142+
143+instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
144+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
145+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
146+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
147+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
148+
149+instance Requester t m => Requester t (EventWriterT t w m) where
150+ type Request (EventWriterT t w m) = Request m
151+ type Response (EventWriterT t w m) = Response m
152+ requesting = lift . requesting
153+ requesting_ = lift . requesting_
154+
155+-- | Given a function like 'runWithReplace' for the underlying monad, implement
156+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
157+-- monad doesn't have a 'MonadAdjust' instance or to override the default
158+-- 'MonadAdjust' behavior.
159+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
160+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
161+ -> EventWriterT t w m a
162+ -> Event t (EventWriterT t w m b)
163+ -> EventWriterT t w m (a, Event t b)
164+runWithReplaceEventWriterTWith f a0 a' = do
165+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
166+ request <- holdDyn (snd result0) $ fmapCheap snd result'
167+ -- 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.)
168+ tellEvent $ coincidence $ updated request
169+ tellEvent $ switch $ current request
170+ return (fst result0, fmapCheap fst result')
171+
172+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
173+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))
174+ => ( (IntMap.Key -> v -> m (Event t w, v'))
175+ -> IntMap v
176+ -> Event t (p v)
177+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
178+ )
179+ -> (p (Event t w) -> [Event t w])
180+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
181+ -> (IntMap.Key -> v -> EventWriterT t w m v')
182+ -> IntMap v
183+ -> Event t (p v)
184+ -> EventWriterT t w m (IntMap v', Event t (p v'))
185+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
186+ let f' :: IntMap.Key -> v -> m (Event t w, v')
187+ f' k v = swap <$> runEventWriterT (f k v)
188+ (children0, children') <- base f' dm0 dm'
189+ let result0 = fmap snd children0
190+ result' = fmapCheap (fmap snd) children'
191+ requests0 :: IntMap (Event t w)
192+ requests0 = fmap fst children0
193+ requests' :: Event t (p (Event t w))
194+ requests' = fmapCheap (fmap fst) children'
195+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
196+ -- 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.)
197+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
198+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
199+ [] -> Nothing
200+ h : t -> Just $ sconcat $ h :| t
201+ return (result0, result')
202+
203+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
204+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))
205+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
206+ -> DMap k v
207+ -> Event t (p k v)
208+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
209+ )
210+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
211+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
212+ -> (p' (Some k) (Event t w) -> [Event t w])
213+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
214+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
215+ -> DMap k v
216+ -> Event t (p k v)
217+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
218+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
219+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
220+ f' k v = Compose . swap <$> runEventWriterT (f k v)
221+ (children0, children') <- base f' dm0 dm'
222+ let result0 = DMap.map (snd . getCompose) children0
223+ result' = fforCheap children' $ mapPatch $ snd . getCompose
224+ requests0 :: Map (Some k) (Event t w)
225+ requests0 = weakenDMapWith (fst . getCompose) children0
226+ requests' :: Event t (p' (Some k) (Event t w))
227+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
228+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
229+ -- 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.)
230+ tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
231+ tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
232+ [] -> Nothing
233+ h : t -> Just $ sconcat $ h :| t
234+ return (result0, result')
235+
236+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
237+ type Performable (EventWriterT t w m) = Performable m
238+ performEvent_ = lift . performEvent_
239+ performEvent = lift . performEvent
240+
241+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
242+ getPostBuild = lift getPostBuild
243+
244+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
245+ newTriggerEvent = lift newTriggerEvent
246+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
247+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
248+
249+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
250+ ask = lift ask
251+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
252+ reader = lift . reader
253+
254+instance MonadRef m => MonadRef (EventWriterT t w m) where
255+ type Ref (EventWriterT t w m) = Ref m
256+ newRef = lift . newRef
257+ readRef = lift . readRef
258+ writeRef r = lift . writeRef r
259+
260+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
261+ atomicModifyRef r = lift . atomicModifyRef r
262+
263+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
264+ newEventWithTrigger = lift . newEventWithTrigger
265+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
266+
267+instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
268+ tellQueryIncremental = lift . tellQueryIncremental
269+ askQueryResult = lift askQueryResult
270+ queryIncremental = lift . queryIncremental
271+
272+-- | Map a function over the output of a 'EventWriterT'.
273+withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)
274+ => (w -> w')
275+ -> EventWriterT t w m a
276+ -> EventWriterT t w' m a
277+withEventWriterT f ew = do
278+ (r, e) <- lift $ do
279+ (r, e) <- runEventWriterT ew
280+ let e' = fmap f e
281+ return (r, e')
282+ tellEvent e
283+ return r
src/Reflex/FastWeak.hsnew file+143
@@ -0,0 +1,143 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+#if GHCJS_FAST_WEAK
5+{-# LANGUAGE ForeignFunctionInterface #-}
6+{-# LANGUAGE JavaScriptFFI #-}
7+#endif
8+module Reflex.FastWeak
9+ ( FastWeakTicket
10+ , FastWeak
11+ , mkFastWeakTicket
12+ , getFastWeakTicketValue
13+ , getFastWeakTicketWeak
14+ , getFastWeakValue
15+ , getFastWeakTicket
16+ , emptyFastWeak
17+#ifdef GHCJS_FAST_WEAK
18+ --TODO: Move these elsewhere
19+ , unsafeFromRawJSVal
20+ , unsafeToRawJSVal
21+ , js_isNull
22+#endif
23+ ) where
24+
25+import GHC.Exts (Any)
26+import Unsafe.Coerce
27+
28+#ifdef GHCJS_FAST_WEAK
29+import GHCJS.Types
30+#else
31+import Control.Exception (evaluate)
32+import System.IO.Unsafe
33+import System.Mem.Weak
34+#endif
35+
36+
37+#ifdef GHCJS_FAST_WEAK
38+newtype FastWeakTicket a = FastWeakTicket JSVal
39+
40+newtype FastWeak a = FastWeak JSVal
41+
42+-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two
43+data Val a = Val { unVal :: a }
44+
45+-- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a'
46+unsafeFromRawJSVal :: JSVal -> a
47+unsafeFromRawJSVal v = unVal (unsafeCoerce v)
48+
49+unsafeToRawJSVal :: a -> JSVal
50+unsafeToRawJSVal v = unsafeCoerce (Val v)
51+#else
52+data FastWeakTicket a = FastWeakTicket
53+ { _fastWeakTicket_val :: !a
54+ , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)
55+ }
56+
57+type FastWeak a = Weak a
58+#endif
59+
60+-- This needs to be in IO so we know that we've relinquished the ticket
61+getFastWeakTicketValue :: FastWeakTicket a -> IO a
62+#ifdef GHCJS_FAST_WEAK
63+getFastWeakTicketValue t = do
64+ v <- js_ticketVal t
65+ return $ unsafeFromRawJSVal v
66+
67+foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal
68+#else
69+getFastWeakTicketValue = return . _fastWeakTicket_val
70+#endif
71+
72+getFastWeakValue :: FastWeak a -> IO (Maybe a)
73+#ifdef GHCJS_FAST_WEAK
74+getFastWeakValue w = do
75+ r <- js_weakVal w
76+ case js_isNull r of
77+ True -> return Nothing
78+ False -> return $ Just $ unsafeFromRawJSVal r
79+
80+foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool
81+
82+foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal
83+#else
84+getFastWeakValue = deRefWeak
85+#endif
86+
87+getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))
88+#ifdef GHCJS_FAST_WEAK
89+getFastWeakTicket w = do
90+ r <- js_weakTicket w
91+ case js_isNull r of
92+ True -> return Nothing
93+ False -> return $ Just $ FastWeakTicket r
94+
95+foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal
96+#else
97+getFastWeakTicket w = do
98+ deRefWeak w >>= \case
99+ Nothing -> return Nothing
100+ Just v -> return $ Just $ FastWeakTicket
101+ { _fastWeakTicket_val = v
102+ , _fastWeakTicket_weak = w
103+ }
104+#endif
105+
106+-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the associated FastWeak to actually be weak
107+mkFastWeakTicket :: a -> IO (FastWeakTicket a)
108+#ifdef GHCJS_FAST_WEAK
109+mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)
110+
111+foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a)
112+#else
113+mkFastWeakTicket v = do
114+ v' <- evaluate v
115+ w <- mkWeakPtr v' Nothing
116+ return $ FastWeakTicket
117+ { _fastWeakTicket_val = v'
118+ , _fastWeakTicket_weak = w
119+ }
120+#endif
121+
122+-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value
123+#ifdef GHCJS_FAST_WEAK
124+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
125+#else
126+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
127+getFastWeakTicketWeak = return . _fastWeakTicket_weak
128+#endif
129+
130+-- | A weak reference that is always empty
131+emptyFastWeak :: FastWeak a
132+emptyFastWeak = unsafeCoerce w
133+ where w :: FastWeak Any
134+#ifdef GHCJS_FAST_WEAK
135+ w = js_emptyWeak
136+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+176
@@ -0,0 +1,176 @@
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+ {-# INLINABLE headE #-}
163+ headE = PerformEventT . lift . headE
164+
165+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
166+ type Ref (PerformEventT t m) = Ref (HostFrame t)
167+ {-# INLINABLE newRef #-}
168+ newRef = PerformEventT . lift . newRef
169+ {-# INLINABLE readRef #-}
170+ readRef = PerformEventT . lift . readRef
171+ {-# INLINABLE writeRef #-}
172+ writeRef r = PerformEventT . lift . writeRef r
173+
174+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
175+ {-# INLINABLE atomicModifyRef #-}
176+ 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+205
@@ -0,0 +1,205 @@
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 Control.Monad.State.Strict (StateT, execStateT, modify)
19+import Data.Coerce
20+import Data.Dependent.Map (DMap, GCompare)
21+import Data.List
22+import Data.FastMutableIntMap
23+import Data.IORef
24+import Data.Map (Map)
25+import qualified Data.Map.Strict as Map
26+import Data.Monoid
27+import Data.Ord
28+import Data.Type.Coercion
29+import Foreign.Ptr
30+import GHC.Foreign
31+import GHC.IO.Encoding
32+import GHC.Stack
33+import Reflex.Class
34+import Reflex.PerformEvent.Class
35+import Reflex.Host.Class
36+
37+import System.IO.Unsafe
38+import Unsafe.Coerce
39+
40+data ProfiledTimeline t
41+
42+{-# NOINLINE profilingData #-}
43+profilingData :: IORef (Map (Ptr CostCentreStack) Int)
44+profilingData = unsafePerformIO $ newIORef Map.empty
45+
46+data CostCentreTree = CostCentreTree
47+ { _costCentreTree_ownEntries :: !Int
48+ , _costCentreTree_cumulativeEntries :: !Int
49+ , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
50+ }
51+ deriving (Show, Eq, Ord)
52+
53+instance Monoid CostCentreTree where
54+ mempty = CostCentreTree 0 0 mempty
55+ CostCentreTree oa ea ca `mappend` CostCentreTree ob eb cb = CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (<>) ca cb
56+
57+getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
58+getCostCentreStack = go []
59+ where go l ccs = if ccs == nullPtr
60+ then return l
61+ else do
62+ cc <- ccsCC ccs
63+ parent <- ccsParent ccs
64+ go (cc : l) parent
65+
66+toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
67+toCostCentreTree ccs n = do
68+ ccList <- getCostCentreStack ccs
69+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
70+
71+getCostCentreTree :: IO CostCentreTree
72+getCostCentreTree = do
73+ vals <- readIORef profilingData
74+ mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
75+
76+formatCostCentreTree :: CostCentreTree -> IO String
77+formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
78+ where go :: Int -> CostCentreTree -> StateT [String] IO ()
79+ go depth cct = do
80+ let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
81+ indent = mconcat $ replicate depth " "
82+ forM_ children $ \(cc, childCct) -> do
83+ lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
84+ mdl <- liftIO $ peekCString utf8 =<< ccModule cc
85+ loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
86+ let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
87+ modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
88+ go (succ depth) childCct
89+
90+showProfilingData :: IO ()
91+showProfilingData = do
92+ putStr =<< formatCostCentreTree =<< getCostCentreTree
93+
94+writeProfilingData :: FilePath -> IO ()
95+writeProfilingData p = do
96+ writeFile p =<< formatCostCentreTree =<< getCostCentreTree
97+
98+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
99+
100+profileEvent :: Reflex t => Event t a -> Event t a
101+profileEvent e = unsafePerformIO $ do
102+ stack <- getCurrentCCS e
103+ let f x = unsafePerformIO $ do
104+ modifyIORef' profilingData $ Map.insertWith (+) stack 1
105+ return $ return $ Just x
106+ return $ pushCheap f e
107+
108+--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
109+
110+instance Reflex t => Reflex (ProfiledTimeline t) where
111+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
112+ newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
113+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
114+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
115+ type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
116+ type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
117+ never = Event_Profiled never
118+ constant = Behavior_Profiled . constant
119+ push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
120+ pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
121+ pull = Behavior_Profiled . pull . coerce
122+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
123+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
124+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
125+ switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
126+ coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
127+ current (Dynamic_Profiled d) = coerce $ current d
128+ updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
129+ unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
130+ unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
131+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
132+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
133+ currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
134+ updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
135+ incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
136+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
137+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
138+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
139+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
140+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
141+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
142+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
143+ fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
144+
145+deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
146+deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
147+deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
148+
149+instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
150+ hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
151+ holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
152+ holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
153+ buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
154+ headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
155+
156+instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
157+ sample (Behavior_Profiled b) = ProfiledM $ sample b
158+
159+instance MonadTrans ProfiledM where
160+ lift = ProfiledM
161+
162+instance MonadIO m => MonadIO (ProfiledM m) where
163+ liftIO = lift . liftIO
164+
165+instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
166+ type Performable (ProfiledM m) = Performable m
167+ performEvent_ = lift . performEvent_ . coerce
168+ performEvent = lift . fmap coerce . performEvent . coerce
169+
170+instance MonadRef m => MonadRef (ProfiledM m) where
171+ type Ref (ProfiledM m) = Ref m
172+ newRef = lift . newRef
173+ readRef = lift . readRef
174+ writeRef r = lift . writeRef r
175+
176+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
177+ newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
178+ newFanEventWithTrigger f = do
179+ es <- lift $ newFanEventWithTrigger f
180+ return $ EventSelector $ \k -> coerce $ select es k
181+
182+instance MonadReader r m => MonadReader r (ProfiledM m) where
183+ ask = lift ask
184+ local f (ProfiledM a) = ProfiledM $ local f a
185+ reader = lift . reader
186+
187+instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
188+ type EventTrigger (ProfiledTimeline t) = EventTrigger t
189+ type EventHandle (ProfiledTimeline t) = EventHandle t
190+ type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
191+
192+instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
193+ subscribeEvent = lift . subscribeEvent . coerce
194+
195+instance PrimMonad m => PrimMonad (ProfiledM m) where
196+ type PrimState (ProfiledM m) = PrimState m
197+ primitive = lift . primitive
198+
199+instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
200+ type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
201+ fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
202+ runHostFrame = lift . runHostFrame . coerce
203+
204+instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
205+ readEvent = lift . fmap coerce . readEvent
src/Reflex/Pure.hsnew file+206
@@ -0,0 +1,206 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE InstanceSigs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+#ifdef USE_REFLEX_OPTIMIZER
9+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10+#endif
11+
12+-- There are two expected orphan instances in this module:
13+-- * MonadSample (Pure t) ((->) t)
14+-- * MonadHold (Pure t) ((->) t)
15+{-# OPTIONS_GHC -fno-warn-orphans #-}
16+
17+-- | This module provides a pure implementation of Reflex, which is intended to
18+-- serve as a reference for the semantics of the Reflex class. All
19+-- implementations of Reflex should produce the same results as this
20+-- implementation, although performance and laziness/strictness may differ.
21+module Reflex.Pure
22+ ( Pure
23+ , Behavior (..)
24+ , Event (..)
25+ , Dynamic (..)
26+ , Incremental (..)
27+ ) where
28+
29+#if !MIN_VERSION_base(4,8,0)
30+import Control.Applicative
31+#endif
32+
33+import Control.Monad
34+import Data.Dependent.Map (DMap, GCompare)
35+import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Identity
37+import Data.IntMap (IntMap)
38+import qualified Data.IntMap as IntMap
39+import Data.Maybe
40+import Data.MemoTrie
41+import Data.Monoid
42+import Data.Type.Coercion
43+import Reflex.Class
44+
45+-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
46+-- with the type @t@.
47+data Pure t
48+
49+-- | The Enum instance of t must be dense: for all x :: t, there must not exist
50+-- any y :: t such that pred x < y < x. The HasTrie instance will be used
51+-- exclusively to memoize functions of t, not for any of its other capabilities.
52+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
53+
54+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
55+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
56+ newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
57+ newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
58+
59+ type PushM (Pure t) = (->) t
60+ type PullM (Pure t) = (->) t
61+
62+ never :: Event (Pure t) a
63+ never = Event $ \_ -> Nothing
64+
65+ constant :: a -> Behavior (Pure t) a
66+ constant x = Behavior $ \_ -> x
67+
68+ push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
69+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
70+
71+ pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
72+ pushCheap = push
73+
74+ pull :: PullM (Pure t) a -> Behavior (Pure t) a
75+ pull = Behavior . memo
76+
77+ -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
78+ -- warning because the GCompare instance is not used; however, removing the
79+ -- GCompare instance produces a different warning, due to that constraint
80+ -- being present in the original class definition
81+
82+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
83+ merge events = Event $ memo $ \t ->
84+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
85+ in if DMap.null currentOccurrences
86+ then Nothing
87+ else Just currentOccurrences
88+
89+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
90+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
91+
92+ switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
93+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
94+
95+ coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
96+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
97+
98+ current :: Dynamic (Pure t) a -> Behavior (Pure t) a
99+ current d = Behavior $ \t -> fst $ unDynamic d t
100+
101+ updated :: Dynamic (Pure t) a -> Event (Pure t) a
102+ updated d = Event $ \t -> snd $ unDynamic d t
103+
104+ unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
105+ unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
106+
107+ -- See UNUSED_CONSTRAINT, above.
108+
109+ --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
110+ --a) -> Incremental (Pure t) p a
111+ unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
112+
113+ mergeIncremental = mergeIncrementalImpl
114+ mergeIncrementalWithMove = mergeIncrementalImpl
115+
116+ currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
117+
118+ updatedIncremental i = Event $ \t -> snd $ unIncremental i t
119+
120+ incrementalToDynamic i = Dynamic $ \t ->
121+ let (old, mPatch) = unIncremental i t
122+ e = case mPatch of
123+ Nothing -> Nothing
124+ Just patch -> apply patch old
125+ in (old, e)
126+ behaviorCoercion Coercion = Coercion
127+ eventCoercion Coercion = Coercion
128+ dynamicCoercion Coercion = Coercion
129+
130+ fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
131+
132+ mergeIntIncremental = mergeIntIncrementalImpl
133+
134+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
135+mergeIncrementalImpl i = Event $ \t ->
136+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
137+ in if DMap.null results
138+ then Nothing
139+ else Just results
140+
141+mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
142+mergeIntIncrementalImpl i = Event $ \t ->
143+ let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
144+ in if IntMap.null results
145+ then Nothing
146+ else Just results
147+
148+instance Functor (Dynamic (Pure t)) where
149+ fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
150+ in (f cur, fmap f upd)
151+
152+instance Applicative (Dynamic (Pure t)) where
153+ pure a = Dynamic $ \_ -> (a, Nothing)
154+ (<*>) = ap
155+
156+instance Monad (Dynamic (Pure t)) where
157+ return = pure
158+ (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
159+ let (curX :: a, updX :: Maybe a) = unDynamic x t
160+ (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
161+ (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
162+ Nothing -> (Nothing, Nothing)
163+ Just nextX -> let (c, u) = unDynamic (f nextX) t
164+ in (Just c, u)
165+ in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
166+
167+instance MonadSample (Pure t) ((->) t) where
168+
169+ sample :: Behavior (Pure t) a -> (t -> a)
170+ sample = unBehavior
171+
172+instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
173+
174+ hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
175+ hold initialValue e initialTime = Behavior f
176+ where f = memo $ \sampleTime ->
177+ -- Really, the sampleTime should never be prior to the initialTime,
178+ -- because that would mean the Behavior is being sampled before
179+ -- being created.
180+ if sampleTime <= initialTime
181+ then initialValue
182+ else let lastTime = pred sampleTime
183+ in fromMaybe (f lastTime) $ unEvent e lastTime
184+
185+ holdDyn v0 = buildDynamic (return v0)
186+
187+ buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
188+ buildDynamic initialValue e initialTime =
189+ let Behavior f = hold (initialValue initialTime) e initialTime
190+ in Dynamic $ \t -> (f t, unEvent e t)
191+
192+ holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
193+ holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
194+ where f = memo $ \sampleTime ->
195+ -- Really, the sampleTime should never be prior to the initialTime,
196+ -- because that would mean the Behavior is being sampled before
197+ -- being created.
198+ if sampleTime <= initialTime
199+ then initialValue
200+ else let lastTime = pred sampleTime
201+ lastValue = f lastTime
202+ in case unEvent e lastTime of
203+ Nothing -> lastValue
204+ Just x -> fromMaybe lastValue $ apply x lastValue
205+
206+ headE = slowHeadE
src/Reflex/Query/Base.hsnew file+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+2460
@@ -0,0 +1,2460 @@
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 :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (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 :: HasSpiderTimeline x => Hold x p -> Subscriber x p -> EventM x (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+ liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
703+ return result
704+
705+{-# INLINABLE readBehaviorUntracked #-}
706+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
707+readBehaviorUntracked b = do
708+ holdInits <- getDeferralQueue
709+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
710+
711+--------------------------------------------------------------------------------
712+-- Dynamic
713+--------------------------------------------------------------------------------
714+
715+data Dynamic x p = Dynamic
716+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
717+ , dynamicUpdated :: !(Event x p)
718+ }
719+
720+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
721+dynamicHold !h = Dynamic
722+ { dynamicCurrent = behaviorHold h
723+ , dynamicUpdated = eventHold h
724+ }
725+
726+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
727+dynamicHoldIdentity = dynamicHold
728+
729+dynamicConst :: PatchTarget p -> Dynamic x p
730+dynamicConst !a = Dynamic
731+ { dynamicCurrent = behaviorConst a
732+ , dynamicUpdated = eventNever
733+ }
734+
735+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
736+dynamicDyn !d = Dynamic
737+ { dynamicCurrent = behaviorDyn d
738+ , dynamicUpdated = eventDyn d
739+ }
740+
741+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
742+dynamicDynIdentity = dynamicDyn
743+
744+--------------------------------------------------------------------------------
745+-- Combinators
746+--------------------------------------------------------------------------------
747+
748+--TODO: Figure out why certain things are not 'representational', then make them
749+--representational so we can use coerce
750+
751+--type role Hold representational
752+data Hold x p
753+ = Hold { holdValue :: !(IORef (PatchTarget p))
754+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
755+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
756+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
757+#ifdef DEBUG_NODEIDS
758+ , holdNodeId :: Int
759+#endif
760+ }
761+
762+-- | A statically allocated 'SpiderTimeline'; this is the only instance of
763+-- 'SpiderTimeline' that can used when using
764+-- -fspecialize-to-spidertimeline-global.
765+data Global
766+
767+{-# NOINLINE globalSpiderTimelineEnv #-}
768+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
769+globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
770+
771+-- | Stores all global data relevant to a particular Spider timeline; only one
772+-- value should exist for each type @x@
773+data SpiderTimelineEnv x = SpiderTimelineEnv
774+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
775+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
776+#ifdef DEBUG
777+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
778+#endif
779+ }
780+type role SpiderTimelineEnv nominal
781+
782+instance Eq (SpiderTimelineEnv x) where
783+ _ == _ = True -- Since only one exists of each type
784+
785+instance GEq SpiderTimelineEnv where
786+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
787+ geqToEq _ = id
788+ geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b
789+ then case unsafeCoerce Refl :: a :~: b of
790+ Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
791+ else different
792+#else
793+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
794+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
795+ else Nothing
796+#endif
797+
798+data EventEnv x
799+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
800+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
801+ , eventEnvDynInits :: !(IORef [SomeDynInit x])
802+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
803+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
804+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
805+ , eventEnvIntClears :: !(IORef [SomeIntClear])
806+ , eventEnvRootClears :: !(IORef [SomeRootClear])
807+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
808+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
809+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
810+ }
811+
812+{-# INLINE runEventM #-}
813+runEventM :: EventM x a -> IO a
814+runEventM = unEventM
815+
816+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
817+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
818+
819+class MonadIO m => Defer a m where
820+ getDeferralQueue :: m (IORef [a])
821+
822+{-# INLINE defer #-}
823+defer :: Defer a m => a -> m ()
824+defer a = do
825+ q <- getDeferralQueue
826+ liftIO $ modifyIORef' q (a:)
827+
828+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
829+ {-# INLINE getDeferralQueue #-}
830+ getDeferralQueue = asksEventEnv eventEnvAssignments
831+
832+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
833+ {-# INLINE getDeferralQueue #-}
834+ getDeferralQueue = asksEventEnv eventEnvHoldInits
835+
836+instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
837+ {-# INLINE getDeferralQueue #-}
838+ getDeferralQueue = asksEventEnv eventEnvDynInits
839+
840+instance Defer (SomeHoldInit x) (BehaviorM x) where
841+ {-# INLINE getDeferralQueue #-}
842+ getDeferralQueue = BehaviorM $ asks snd
843+
844+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
845+ {-# INLINE getDeferralQueue #-}
846+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
847+
848+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
849+ {-# INLINE getDeferralQueue #-}
850+ getDeferralQueue = asksEventEnv eventEnvMergeInits
851+
852+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
853+ getCurrentHeight :: m Height
854+ scheduleMerge :: Height -> EventM x () -> m ()
855+
856+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
857+ {-# INLINE getCurrentHeight #-}
858+ getCurrentHeight = do
859+ heightRef <- asksEventEnv eventEnvCurrentHeight
860+ liftIO $ readIORef heightRef
861+ {-# INLINE scheduleMerge #-}
862+ scheduleMerge height subscribed = do
863+ delayedRef <- asksEventEnv eventEnvDelayedMerges
864+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
865+
866+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
867+class x ~ Global => HasSpiderTimeline x where
868+#else
869+class HasSpiderTimeline x where
870+#endif
871+ -- | Retrieve the current SpiderTimelineEnv
872+ spiderTimeline :: SpiderTimelineEnv x
873+
874+instance HasSpiderTimeline Global where
875+ spiderTimeline = globalSpiderTimelineEnv
876+
877+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
878+putCurrentHeight h = do
879+ heightRef <- asksEventEnv eventEnvCurrentHeight
880+ liftIO $ writeIORef heightRef $! h
881+
882+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
883+ {-# INLINE getDeferralQueue #-}
884+ getDeferralQueue = asksEventEnv eventEnvClears
885+
886+{-# INLINE scheduleClear #-}
887+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
888+scheduleClear r = defer $ SomeClear r
889+
890+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
891+ {-# INLINE getDeferralQueue #-}
892+ getDeferralQueue = asksEventEnv eventEnvIntClears
893+
894+{-# INLINE scheduleIntClear #-}
895+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
896+scheduleIntClear r = defer $ SomeIntClear r
897+
898+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
899+ {-# INLINE getDeferralQueue #-}
900+ getDeferralQueue = asksEventEnv eventEnvRootClears
901+
902+{-# INLINE scheduleRootClear #-}
903+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
904+scheduleRootClear r = defer $ SomeRootClear r
905+
906+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
907+ {-# INLINE getDeferralQueue #-}
908+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
909+
910+-- Note: hold cannot examine its event until after the phase is over
911+{-# INLINE [1] hold #-}
912+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
913+hold v0 e = do
914+ valRef <- liftIO $ newIORef v0
915+ invsRef <- liftIO $ newIORef []
916+ parentRef <- liftIO $ newIORef Nothing
917+#ifdef DEBUG_NODEIDS
918+ nodeId <- liftIO newNodeId
919+#endif
920+ let h = Hold
921+ { holdValue = valRef
922+ , holdInvalidators = invsRef
923+ , holdEvent = e
924+ , holdParent = parentRef
925+#ifdef DEBUG_NODEIDS
926+ , holdNodeId = nodeId
927+#endif
928+ }
929+ defer $ SomeHoldInit h
930+ return h
931+
932+{-# INLINE getHoldEventSubscription #-}
933+getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)
934+getHoldEventSubscription h = do
935+ ep <- liftIO $ readIORef $ holdParent h
936+ case ep of
937+ Just subd -> return subd
938+ Nothing -> do
939+ let e = holdEvent h
940+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
941+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
942+ liftIO $ writeIORef subscriptionRef $! subscription
943+ case occ of
944+ Nothing -> return ()
945+ Just o -> do
946+ old <- liftIO $ readIORef $ holdValue h
947+ case apply o old of
948+ Nothing -> return ()
949+ Just new -> do
950+ -- Need to evaluate these so that we don't retain the Hold itself
951+ v <- liftIO $ evaluate $ holdValue h
952+ i <- liftIO $ evaluate $ holdInvalidators h
953+ defer $ SomeAssignment v i new
954+ liftIO $ writeIORef (holdParent h) $ Just subscription
955+ return subscription
956+
957+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
958+
959+--type role BehaviorM representational
960+-- BehaviorM can sample behaviors
961+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
962+
963+instance Monad (BehaviorM x) where
964+ {-# INLINE (>>=) #-}
965+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
966+ {-# INLINE (>>) #-}
967+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
968+ {-# INLINE return #-}
969+ return x = BehaviorM $ return x
970+ {-# INLINE fail #-}
971+ fail s = BehaviorM $ fail s
972+
973+data BehaviorSubscribed x a
974+ = forall p. BehaviorSubscribedHold (Hold x p)
975+ | BehaviorSubscribedPull (PullSubscribed x a)
976+
977+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
978+
979+--type role PullSubscribed representational
980+data PullSubscribed x a
981+ = PullSubscribed { pullSubscribedValue :: !a
982+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
983+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
984+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
985+ }
986+
987+--type role Pull representational
988+data Pull x a
989+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
990+ , pullCompute :: !(BehaviorM x a)
991+#ifdef DEBUG_NODEIDS
992+ , pullNodeId :: Int
993+#endif
994+ }
995+
996+data Invalidator x
997+ = forall a. InvalidatorPull (Pull x a)
998+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
999+
1000+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1001+ { rootSubscribedKey :: !(k a)
1002+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
1003+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1004+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
1005+ , rootSubscribedUninit :: IO ()
1006+ , 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?
1007+#ifdef DEBUG_NODEIDS
1008+ , rootSubscribedNodeId :: Int
1009+#endif
1010+ }
1011+
1012+data Root x (k :: * -> *)
1013+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1014+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1015+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1016+ }
1017+
1018+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
1019+
1020+data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
1021+
1022+data SomeMergeUpdate x = SomeMergeUpdate
1023+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1024+ , _someMergeUpdate_invalidateHeight :: !(IO ())
1025+ , _someMergeUpdate_recalculateHeight :: !(IO ())
1026+ }
1027+
1028+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1029+
1030+-- EventM can do everything BehaviorM can, plus create holds
1031+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
1032+
1033+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1034+
1035+data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1036+ { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1037+ , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1038+ }
1039+
1040+data HeightBag = HeightBag
1041+ { _heightBag_size :: {-# UNPACK #-} !Int
1042+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1043+ }
1044+ deriving (Show, Read, Eq, Ord)
1045+
1046+heightBagEmpty :: HeightBag
1047+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1048+
1049+heightBagSize :: HeightBag -> Int
1050+heightBagSize = _heightBag_size
1051+
1052+heightBagFromList :: [Height] -> HeightBag
1053+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1054+
1055+heightBagAdd :: Height -> HeightBag -> HeightBag
1056+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1057+
1058+heightBagRemove :: Height -> HeightBag -> HeightBag
1059+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1060+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1061+ Just old -> HeightBag (pred s) $ case old of
1062+ 0 -> IntMap.delete h c
1063+ _ -> IntMap.insert h (pred old) c
1064+
1065+heightBagMax :: HeightBag -> Height
1066+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1067+ Just ((h, _), _) -> Height h
1068+ Nothing -> zeroHeight
1069+
1070+heightBagVerify :: HeightBag -> HeightBag
1071+#ifdef DEBUG
1072+heightBagVerify b@(HeightBag s c) = if
1073+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1074+ -> error $ "heightBagVerify: size doesn't match: " <> show b
1075+ | unHeight invalidHeight `IntMap.member` c
1076+ -> error $ "heightBagVerify: contains invalid height: " <> show b
1077+ | otherwise -> b
1078+#else
1079+heightBagVerify = id
1080+#endif
1081+
1082+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1083+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1084+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1085+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1086+ }
1087+
1088+data FanSubscribed (x :: *) k
1089+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1090+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1091+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1092+ , fanSubscribedParent :: !(EventSubscription x)
1093+#ifdef DEBUG_NODEIDS
1094+ , fanSubscribedNodeId :: Int
1095+#endif
1096+ }
1097+
1098+data Fan x k
1099+ = Fan { fanParent :: !(Event x (DMap k Identity))
1100+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1101+ }
1102+
1103+data SwitchSubscribed x a
1104+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1105+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
1106+ , switchSubscribedHeight :: !(IORef Height)
1107+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1108+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1109+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1110+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1111+ , switchSubscribedParent :: !(Behavior x (Event x a))
1112+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1113+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1114+#ifdef DEBUG_NODEIDS
1115+ , switchSubscribedNodeId :: Int
1116+#endif
1117+ }
1118+
1119+data Switch x a
1120+ = Switch { switchParent :: !(Behavior x (Event x a))
1121+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1122+ }
1123+
1124+#ifdef USE_TEMPLATE_HASKELL
1125+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1126+#endif
1127+data CoincidenceSubscribed x a
1128+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1129+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1130+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1131+ , coincidenceSubscribedHeight :: !(IORef Height)
1132+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1133+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1134+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1135+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1136+#ifdef DEBUG_NODEIDS
1137+ , coincidenceSubscribedNodeId :: Int
1138+#endif
1139+ }
1140+
1141+data Coincidence x a
1142+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1143+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1144+ }
1145+
1146+{-# NOINLINE newInvalidatorSwitch #-}
1147+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1148+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1149+
1150+{-# NOINLINE newInvalidatorPull #-}
1151+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1152+newInvalidatorPull p = return $! InvalidatorPull p
1153+
1154+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1155+ fmapMaybe f = push $ return . f
1156+
1157+instance HasSpiderTimeline x => Align (Event x) where
1158+ nil = eventNever
1159+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1160+
1161+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1162+
1163+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1164+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1165+
1166+--TODO: Avoid the duplication between this and R.zipDynWith
1167+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1168+zipDynWith f da db =
1169+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
1170+ ec = flip push eab $ \o -> do
1171+ (a, b) <- case o of
1172+ This (Identity a) -> do
1173+ b <- readBehaviorUntracked $ dynamicCurrent db
1174+ return (a, b)
1175+ That (Identity b) -> do
1176+ a <- readBehaviorUntracked $ dynamicCurrent da
1177+ return (a, b)
1178+ These (Identity a) (Identity b) -> return (a, b)
1179+ return $ Just $ Identity $ f a b
1180+ in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1181+
1182+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1183+buildDynamic readV0 v' = do
1184+ result <- liftIO $ newIORef $ Left (readV0, v')
1185+ let !d = Dyn result
1186+ defer $ SomeDynInit d
1187+ return d
1188+
1189+unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1190+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1191+ where x = (readV0, v')
1192+
1193+-- ResultM can read behaviors and events
1194+type ResultM = EventM
1195+
1196+{-# NOINLINE unsafeNewIORef #-}
1197+unsafeNewIORef :: a -> b -> IORef b
1198+unsafeNewIORef a b = unsafePerformIO $ do
1199+ touch a
1200+ newIORef b
1201+
1202+instance HasSpiderTimeline x => Functor (Event x) where
1203+ fmap f = push $ return . Just . f
1204+
1205+instance Functor (Behavior x) where
1206+ fmap f = pull . fmap f . readBehaviorTracked
1207+
1208+{-# INLINE push #-}
1209+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1210+push f e = cacheEvent (pushCheap f e)
1211+
1212+{-# INLINABLE pull #-}
1213+pull :: BehaviorM x a -> Behavior x a
1214+pull a = behaviorPull $ Pull
1215+ { pullCompute = a
1216+ , pullValue = unsafeNewIORef a Nothing
1217+#ifdef DEBUG_NODEIDS
1218+ , pullNodeId = unsafeNodeId a
1219+#endif
1220+ }
1221+
1222+{-# INLINABLE switch #-}
1223+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1224+switch a = eventSwitch $ Switch
1225+ { switchParent = a
1226+ , switchSubscribed = unsafeNewIORef a Nothing
1227+ }
1228+
1229+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1230+coincidence a = eventCoincidence $ Coincidence
1231+ { coincidenceParent = a
1232+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1233+ }
1234+
1235+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1236+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1237+run roots after = do
1238+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1239+ t <- SpiderHost ask
1240+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1241+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1242+ occBefore <- liftIO $ do
1243+ occBefore <- readIORef occRef
1244+ writeIORef occRef $! DMap.insert k a occBefore
1245+ return occBefore
1246+ if DMap.null occBefore
1247+ then do scheduleRootClear occRef
1248+ return $ Just r
1249+ else return Nothing
1250+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1251+ propagate a subscribersRef
1252+ delayedRef <- asksEventEnv eventEnvDelayedMerges
1253+ let go = do
1254+ delayed <- liftIO $ readIORef delayedRef
1255+ case IntMap.minViewWithKey delayed of
1256+ Nothing -> return ()
1257+ Just ((currentHeight, cur), future) -> do
1258+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1259+ putCurrentHeight $ Height currentHeight
1260+ liftIO $ writeIORef delayedRef $! future
1261+ sequence_ cur
1262+ go
1263+ go
1264+ putCurrentHeight maxBound
1265+ after
1266+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1267+ return result
1268+
1269+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1270+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1271+ height <- liftIO $ readIORef heightRef
1272+ currentHeight <- getCurrentHeight
1273+ case height `compare` currentHeight of
1274+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1275+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1276+ EQ -> a
1277+
1278+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1279+
1280+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1281+
1282+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1283+
1284+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1285+
1286+debugFinalize :: Bool
1287+debugFinalize = False
1288+
1289+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1290+mkWeakPtrWithDebug x debugNote = do
1291+ x' <- evaluate x
1292+ mkWeakPtr x' $
1293+ if debugFinalize
1294+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1295+ else Nothing
1296+
1297+type WeakList a = [Weak a]
1298+
1299+{-# INLINE withIncreasedDepth #-}
1300+#ifdef DEBUG
1301+withIncreasedDepth :: CanTrace x m => m a -> m a
1302+withIncreasedDepth a = do
1303+ spiderTimeline <- askSpiderTimelineEnv
1304+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1305+ result <- a
1306+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1307+ return result
1308+#else
1309+withIncreasedDepth :: m a -> m a
1310+withIncreasedDepth = id
1311+#endif
1312+
1313+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1314+
1315+{-# INLINE tracePropagate #-}
1316+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1317+tracePropagate p = traceWhen p debugPropagate
1318+
1319+{-# INLINE traceInvalidate #-}
1320+traceInvalidate :: String -> IO ()
1321+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1322+
1323+{-# INLINE traceWhen #-}
1324+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1325+traceWhen p b message = traceMWhen p b $ return message
1326+
1327+{-# INLINE traceMWhen #-}
1328+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1329+traceMWhen _ b getMessage = when b $ do
1330+ message <- getMessage
1331+#ifdef DEBUG
1332+ spiderTimeline <- askSpiderTimelineEnv
1333+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1334+#else
1335+ let d = 0
1336+#endif
1337+ liftIO $ putStrLn $ replicate d ' ' <> message
1338+
1339+whoCreatedIORef :: IORef a -> IO [String]
1340+whoCreatedIORef (IORef a) = whoCreated $! a
1341+
1342+#ifdef DEBUG_CYCLES
1343+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1344+groupByHead = \case
1345+ [] -> []
1346+ (x :| xs) : t -> case groupByHead t of
1347+ [] -> [(x, xs :| [])]
1348+ l@((y, yss) : t')
1349+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1350+ | otherwise -> (x, xs :| []) : l
1351+
1352+listsToForest :: Eq a => [[a]] -> Forest a
1353+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1354+#endif
1355+
1356+{-# INLINE propagateSubscriberHold #-}
1357+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1358+propagateSubscriberHold h a = do
1359+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1360+ invalidators <- liftIO $ readIORef $ holdInvalidators h
1361+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1362+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1363+ case {-# SCC "apply" #-} apply a v of
1364+ Nothing -> return ()
1365+ Just v' -> do
1366+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1367+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1368+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1369+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1370+
1371+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1372+
1373+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1374+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1375+
1376+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1377+askInvalidator = do
1378+ (!m, _) <- BehaviorM ask
1379+ case m of
1380+ Nothing -> return Nothing
1381+ Just (!wi, _) -> return $ Just wi
1382+
1383+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1384+askParentsRef = do
1385+ (!m, _) <- BehaviorM ask
1386+ case m of
1387+ Nothing -> return Nothing
1388+ Just (_, !p) -> return $ Just p
1389+
1390+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1391+askBehaviorHoldInits = do
1392+ (_, !his) <- BehaviorM ask
1393+ return his
1394+
1395+{-# INLINE getDynHold #-}
1396+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1397+getDynHold d = do
1398+ mh <- liftIO $ readIORef $ unDyn d
1399+ case mh of
1400+ Right h -> return h
1401+ Left (readV0, v') -> do
1402+ holdInits <- getDeferralQueue
1403+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1404+ h <- hold v0 v'
1405+ liftIO $ writeIORef (unDyn d) $ Right h
1406+ return h
1407+
1408+-- Always refers to 0
1409+{-# NOINLINE zeroRef #-}
1410+zeroRef :: IORef Height
1411+zeroRef = unsafePerformIO $ newIORef zeroHeight
1412+
1413+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1414+getRootSubscribed k r sub = do
1415+ mSubscribed <- readIORef $ rootSubscribed r
1416+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1417+ case DMap.lookup k mSubscribed of
1418+ Just subscribed -> {-# SCC "hitRoot" #-} do
1419+ sln <- subscribeRootSubscribed subscribed sub
1420+ occ <- getOcc
1421+ return (sln, subscribed, occ)
1422+ Nothing -> {-# SCC "missRoot" #-} do
1423+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1424+ let !cached = rootSubscribed r
1425+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1426+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1427+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1428+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1429+ writeIORef uninitRef $! uninit
1430+ let !subscribed = RootSubscribed
1431+ { rootSubscribedKey = k
1432+ , rootSubscribedCachedSubscribed = cached
1433+ , rootSubscribedOccurrence = getOcc
1434+ , rootSubscribedSubscribers = subs
1435+ , rootSubscribedUninit = uninit
1436+ , rootSubscribedWeakSelf = weakSelf
1437+#ifdef DEBUG_NODEIDS
1438+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1439+#endif
1440+ }
1441+ -- If we die at the same moment that all our children die, they will
1442+ -- try to clean us up but will fail because their Weak reference to us
1443+ -- will also be dead. So, if we are dying, check if there are any
1444+ -- children; since children don't bother cleaning themselves up if
1445+ -- their parents are already dead, I don't think there's a race
1446+ -- condition here. However, if there are any children, then we can
1447+ -- infer that we need to clean ourselves up, so we do.
1448+ finalCleanup = do
1449+ cs <- readIORef $ _weakBag_children subs
1450+ when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1451+ writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1452+ 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
1453+ occ <- getOcc
1454+ return (sln, subscribed, occ)
1455+
1456+#ifdef USE_TEMPLATE_HASKELL
1457+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1458+#endif
1459+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1460+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1461+ rootSubscribedUninit self
1462+ modifyIORef' cached $ DMap.delete k
1463+
1464+{-# INLINE subscribeRootSubscribed #-}
1465+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1466+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1467+
1468+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1469+
1470+data FanInt x a = FanInt
1471+ { _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
1472+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1473+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1474+ }
1475+
1476+newFanInt :: IO (FanInt x a)
1477+newFanInt = do
1478+ 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
1479+ subscriptionRef <- newIORef $ error "fanInt: no subscription"
1480+ occRef <- newIORef $ error "fanInt: no occurrence"
1481+ return $ FanInt
1482+ { _fanInt_subscribers = subscribers
1483+ , _fanInt_subscriptionRef = subscriptionRef
1484+ , _fanInt_occRef = occRef
1485+ }
1486+
1487+{-# NOINLINE unsafeNewFanInt #-}
1488+unsafeNewFanInt :: b -> FanInt x a
1489+unsafeNewFanInt b = unsafePerformIO $ do
1490+ touch b
1491+ newFanInt
1492+
1493+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1494+fanInt p =
1495+ let self = unsafeNewFanInt p
1496+ in EventSelectorInt $ \k -> Event $ \sub -> do
1497+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1498+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1499+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1500+ { subscriberPropagate = \m -> do
1501+ liftIO $ writeIORef (_fanInt_occRef self) m
1502+ scheduleIntClear $ _fanInt_occRef self
1503+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1504+ FastWeakBag.traverse b $ \s -> do
1505+ subscriberPropagate s v
1506+ , subscriberInvalidateHeight = \old -> do
1507+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1508+ FastWeakBag.traverse b $ \s -> do
1509+ subscriberInvalidateHeight s old
1510+ , subscriberRecalculateHeight = \new -> do
1511+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1512+ FastWeakBag.traverse b $ \s -> do
1513+ subscriberRecalculateHeight s new
1514+ }
1515+ liftIO $ do
1516+ writeIORef (_fanInt_subscriptionRef self) subscription
1517+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1518+ scheduleIntClear $ _fanInt_occRef self
1519+ liftIO $ do
1520+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1521+ Nothing -> do
1522+ b <- FastWeakBag.empty
1523+ FastMutableIntMap.insert (_fanInt_subscribers self) k b
1524+ return b
1525+ Just b -> return b
1526+ t <- liftIO $ FastWeakBag.insert sub b
1527+ currentOcc <- readIORef (_fanInt_occRef self)
1528+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1529+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1530+
1531+{-# INLINABLE getFanSubscribed #-}
1532+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1533+getFanSubscribed k f sub = do
1534+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1535+ case mSubscribed of
1536+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1537+ sln <- subscribeFanSubscribed k subscribed sub
1538+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1539+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1540+ Nothing -> {-# SCC "missFan" #-} do
1541+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1542+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1543+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1544+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1545+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1546+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1547+ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1548+ occRef <- liftIO $ newIORef parentOcc
1549+ when (isJust parentOcc) $ scheduleClear occRef
1550+ let subscribed = FanSubscribed
1551+ { fanSubscribedCachedSubscribed = fanSubscribed f
1552+ , fanSubscribedOccurrence = occRef
1553+ , fanSubscribedParent = subscription
1554+ , fanSubscribedSubscribers = subscribersRef
1555+#ifdef DEBUG_NODEIDS
1556+ , fanSubscribedNodeId = unsafeNodeId f
1557+#endif
1558+ }
1559+ let !self = (k, subscribed)
1560+ liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1561+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1562+ liftIO $ writeIORef subscribedRef $! subscribed
1563+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1564+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1565+
1566+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1567+cleanupFanSubscribed (k, subscribed) = do
1568+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1569+ let reducedSubscribers = DMap.delete k subscribers
1570+ if DMap.null reducedSubscribers
1571+ then do
1572+ unsubscribe $ fanSubscribedParent subscribed
1573+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1574+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1575+ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1576+
1577+{-# INLINE subscribeFanSubscribed #-}
1578+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1579+subscribeFanSubscribed k subscribed sub = do
1580+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1581+ case DMap.lookup k subscribers of
1582+ Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1583+ let !self = (k, subscribed)
1584+ weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1585+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1586+ 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
1587+ return sln
1588+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1589+
1590+{-# INLINABLE getSwitchSubscribed #-}
1591+getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1592+getSwitchSubscribed s sub = do
1593+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1594+ case mSubscribed of
1595+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1596+ sln <- subscribeSwitchSubscribed subscribed sub
1597+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1598+ return (sln, subscribed, occ)
1599+ Nothing -> {-# SCC "missSwitch" #-} do
1600+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1601+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1602+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1603+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1604+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1605+ wiRef <- liftIO $ newIORef wi
1606+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1607+ holdInits <- getDeferralQueue
1608+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1609+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1610+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1611+ subscriptionRef <- liftIO $ newIORef subscription
1612+ occRef <- liftIO $ newIORef parentOcc
1613+ when (isJust parentOcc) $ scheduleClear occRef
1614+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1615+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1616+ let !subscribed = SwitchSubscribed
1617+ { switchSubscribedCachedSubscribed = switchSubscribed s
1618+ , switchSubscribedOccurrence = occRef
1619+ , switchSubscribedHeight = heightRef
1620+ , switchSubscribedSubscribers = subs
1621+ , switchSubscribedOwnInvalidator = i
1622+ , switchSubscribedOwnWeakInvalidator = wiRef
1623+ , switchSubscribedBehaviorParents = parentsRef
1624+ , switchSubscribedParent = switchParent s
1625+ , switchSubscribedCurrentParent = subscriptionRef
1626+ , switchSubscribedWeakSelf = weakSelf
1627+#ifdef DEBUG_NODEIDS
1628+ , switchSubscribedNodeId = unsafeNodeId s
1629+#endif
1630+ }
1631+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1632+ liftIO $ writeIORef subscribedRef $! subscribed
1633+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1634+ return (slnForSub, subscribed, parentOcc)
1635+
1636+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1637+cleanupSwitchSubscribed subscribed = do
1638+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1639+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1640+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1641+
1642+{-# INLINE subscribeSwitchSubscribed #-}
1643+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1644+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1645+
1646+{-# INLINABLE getCoincidenceSubscribed #-}
1647+getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1648+getCoincidenceSubscribed c sub = do
1649+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1650+ case mSubscribed of
1651+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1652+ sln <- subscribeCoincidenceSubscribed subscribed sub
1653+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1654+ return (sln, subscribed, occ)
1655+ Nothing -> {-# SCC "missCoincidence" #-} do
1656+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1657+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1658+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1659+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1660+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1661+ (occ, height, mInnerSubd) <- case outerOcc of
1662+ Nothing -> return (Nothing, outerHeight, Nothing)
1663+ Just o -> do
1664+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1665+ return (occ, height, Just innerSubd)
1666+ occRef <- liftIO $ newIORef occ
1667+ when (isJust occ) $ scheduleClear occRef
1668+ heightRef <- liftIO $ newIORef height
1669+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1670+ scheduleClear innerSubdRef
1671+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1672+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1673+ let subscribed = CoincidenceSubscribed
1674+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1675+ , coincidenceSubscribedOccurrence = occRef
1676+ , coincidenceSubscribedHeight = heightRef
1677+ , coincidenceSubscribedSubscribers = subs
1678+ , coincidenceSubscribedOuter = subOuter
1679+ , coincidenceSubscribedOuterParent = outerSubscription
1680+ , coincidenceSubscribedInnerParent = innerSubdRef
1681+ , coincidenceSubscribedWeakSelf = weakSelf
1682+#ifdef DEBUG_NODEIDS
1683+ , coincidenceSubscribedNodeId = unsafeNodeId c
1684+#endif
1685+ }
1686+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1687+ liftIO $ writeIORef subscribedRef $! subscribed
1688+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1689+ return (slnForSub, subscribed, occ)
1690+
1691+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1692+cleanupCoincidenceSubscribed subscribed = do
1693+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1694+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1695+
1696+{-# INLINE subscribeCoincidenceSubscribed #-}
1697+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1698+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1699+
1700+{-# INLINE merge #-}
1701+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1702+merge d = cacheEvent (mergeCheap d)
1703+
1704+{-# INLINE mergeWithMove #-}
1705+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1706+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1707+
1708+{-# INLINE [1] mergeCheap #-}
1709+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1710+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1711+ where
1712+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1713+ updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1714+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1715+ (mOldSubd, newPs) <- case me of
1716+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1717+ Just e -> do
1718+ let s = subscriber $ return k
1719+ subscription@(EventSubscription _ subd) <- subscribe e s
1720+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1721+ let newParent = MergeSubscribedParent subscription
1722+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1723+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1724+ forM_ mOldSubd $ \oldSubd -> do
1725+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1726+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1727+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1728+ foldM f ([], oldParents) $ DMap.toList p
1729+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1730+ getInitialSubscribers initialParents subscriber = do
1731+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1732+ let s = subscriber $ return k
1733+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1734+ height <- liftIO $ getEventSubscribedHeight parentSubd
1735+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1736+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1737+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1738+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1739+ )
1740+ destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1741+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1742+
1743+{-# INLINE [1] mergeCheapWithMove #-}
1744+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1745+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1746+ where
1747+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1748+ updateMe subscriber heightBagRef oldParents p = do
1749+ -- Prepare new parents for insertion
1750+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1751+ subscribeParent k e = do
1752+ keyRef <- liftIO $ newIORef k
1753+ let s = subscriber $ liftIO $ readIORef keyRef
1754+ subscription@(EventSubscription _ subd) <- subscribe e s
1755+ liftIO $ do
1756+ newParentHeight <- getEventSubscribedHeight subd
1757+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1758+ return $ MergeSubscribedParentWithMove subscription keyRef
1759+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1760+ -- Collect old parents for deletion and update the keys of moved parents
1761+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1762+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1763+ Nothing -> do
1764+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1765+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1766+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1767+ Just toKey -> do
1768+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1769+ return Nothing
1770+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1771+ return (toDelete, applyAlways p' oldParents)
1772+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1773+ getInitialSubscribers initialParents subscriber = do
1774+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1775+ keyRef <- liftIO $ newIORef k
1776+ let s = subscriber $ liftIO $ readIORef keyRef
1777+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1778+ height <- liftIO $ getEventSubscribedHeight parentSubd
1779+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1780+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1781+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1782+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1783+ )
1784+ destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1785+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1786+
1787+type MergeUpdateFunc k x p s
1788+ = (forall a. EventM x (k a) -> Subscriber x a)
1789+ -> IORef HeightBag
1790+ -> DMap k s
1791+ -> p
1792+ -> EventM x ([EventSubscription x], DMap k s)
1793+
1794+type MergeInitFunc k x s
1795+ = DMap k (Event x)
1796+ -> (forall a. EventM x (k a) -> Subscriber x a)
1797+ -> EventM x (DMap k Identity, [Height], DMap k s)
1798+
1799+type MergeDestroyFunc k s
1800+ = DMap k s
1801+ -> IO ()
1802+
1803+data Merge x k s = Merge
1804+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1805+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1806+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1807+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1808+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1809+ }
1810+
1811+invalidateMergeHeight :: Merge x k s -> IO ()
1812+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1813+
1814+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1815+invalidateMergeHeight' heightRef sub = do
1816+ oldHeight <- readIORef heightRef
1817+ 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
1818+ writeIORef heightRef $! invalidHeight
1819+ subscriberInvalidateHeight sub oldHeight
1820+
1821+
1822+revalidateMergeHeight :: Merge x k s -> IO ()
1823+revalidateMergeHeight m = do
1824+ currentHeight <- readIORef $ _merge_heightRef m
1825+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1826+ heights <- readIORef $ _merge_heightBagRef m
1827+ parents <- readIORef $ _merge_parentsRef m
1828+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1829+ case heightBagSize heights `compare` DMap.size parents of
1830+ LT -> return ()
1831+ EQ -> do
1832+ let height = succHeight $ heightBagMax heights
1833+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1834+ writeIORef (_merge_heightRef m) $! height
1835+ subscriberRecalculateHeight (_merge_sub m) height
1836+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1837+
1838+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1839+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1840+ vals <- liftIO $ readIORef $ _merge_accumRef m
1841+ 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
1842+ --TODO: Assert that m is not empty
1843+ subscriberPropagate (_merge_sub m) vals
1844+
1845+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1846+mergeSubscriber m getKey = Subscriber
1847+ { subscriberPropagate = \a -> do
1848+ oldM <- liftIO $ readIORef $ _merge_accumRef m
1849+ k <- getKey
1850+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1851+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1852+ liftIO $ writeIORef (_merge_accumRef m) $! newM
1853+ when (DMap.null oldM) $ do -- Only schedule the firing once
1854+ height <- liftIO $ readIORef $ _merge_heightRef m
1855+ --TODO: assertions about height
1856+ currentHeight <- getCurrentHeight
1857+ when (height <= currentHeight) $ do
1858+ if height /= invalidHeight
1859+ then do
1860+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1861+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1862+ else liftIO $ do
1863+#ifdef DEBUG_CYCLES
1864+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1865+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1866+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1867+#else
1868+ let cycleInfo = ""
1869+#endif
1870+ error $ "Causality loop found" <> cycleInfo
1871+ scheduleMergeSelf m height
1872+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1873+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1874+ invalidateMergeHeight m
1875+ , subscriberRecalculateHeight = \new -> do
1876+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1877+ revalidateMergeHeight m
1878+ }
1879+
1880+--TODO: Be able to run as much of this as possible promptly
1881+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1882+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1883+ where updateMe = do
1884+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1885+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1886+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1887+ return subscriptionsToKill
1888+
1889+{-# INLINE mergeCheap' #-}
1890+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)
1891+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1892+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1893+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1894+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1895+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1896+ parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1897+ let m = Merge
1898+ { _merge_parentsRef = parentsRef
1899+ , _merge_heightBagRef = heightBagRef
1900+ , _merge_heightRef = heightRef
1901+ , _merge_sub = sub
1902+ , _merge_accumRef = accumRef
1903+ }
1904+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1905+ let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1906+ myHeight = if invalidHeight `elem` heights
1907+ then invalidHeight
1908+ else succHeight $ heightBagMax myHeightBag
1909+ currentHeight <- getCurrentHeight
1910+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1911+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1912+ else (Nothing, dm)
1913+ unless (DMap.null accum) $ do
1914+ scheduleMergeSelf m myHeight
1915+ liftIO $ writeIORef accumRef $! accum
1916+ liftIO $ writeIORef heightRef $! myHeight
1917+ liftIO $ writeIORef heightBagRef $! myHeightBag
1918+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1919+ liftIO $ writeIORef parentsRef $! initialParentState
1920+ defer $ SomeMergeInit $ do
1921+ let s = Subscriber
1922+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1923+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1924+ defer $ updateMerge m updateFunc a
1925+ , subscriberInvalidateHeight = \_ -> return ()
1926+ , subscriberRecalculateHeight = \_ -> return ()
1927+ }
1928+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1929+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
1930+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1931+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1932+ -- its subscription.
1933+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1934+ let unsubscribeAll = destroy =<< readIORef parentsRef
1935+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1936+ , occ
1937+ )
1938+
1939+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1940+mergeInt = cacheEvent . mergeIntCheap
1941+
1942+{-# INLINABLE mergeIntCheap #-}
1943+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1944+mergeIntCheap d = Event $ \sub -> do
1945+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1946+ accum <- liftIO $ FastMutableIntMap.newEmpty
1947+ heightRef <- liftIO $ newIORef zeroHeight
1948+ heightBagRef <- liftIO $ newIORef heightBagEmpty
1949+ parents <- liftIO $ FastMutableIntMap.newEmpty
1950+ let scheduleSelf = do
1951+ height <- liftIO $ readIORef $ heightRef
1952+ scheduleMerge' height heightRef $ do
1953+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
1954+ subscriberPropagate sub vals
1955+ invalidateMyHeight = do
1956+ invalidateMergeHeight' heightRef sub
1957+ recalculateMyHeight = do
1958+ currentHeight <- readIORef heightRef
1959+ 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?
1960+ heights <- readIORef heightBagRef
1961+ numParents <- FastMutableIntMap.size parents
1962+ case heightBagSize heights `compare` numParents of
1963+ LT -> return ()
1964+ EQ -> do
1965+ let height = succHeight $ heightBagMax heights
1966+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1967+ writeIORef heightRef $! height
1968+ subscriberRecalculateHeight sub height
1969+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1970+ mySubscriber k = Subscriber
1971+ { subscriberPropagate = \a -> do
1972+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1973+ liftIO $ FastMutableIntMap.insert accum k a
1974+ when wasEmpty scheduleSelf
1975+ , subscriberInvalidateHeight = \old -> do
1976+ modifyIORef' heightBagRef $ heightBagRemove old
1977+ invalidateMyHeight
1978+ , subscriberRecalculateHeight = \new -> do
1979+ modifyIORef' heightBagRef $ heightBagAdd new
1980+ recalculateMyHeight
1981+ }
1982+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do
1983+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
1984+ liftIO $ do
1985+ forM_ parentOcc $ FastMutableIntMap.insert accum k
1986+ FastMutableIntMap.insert parents k subscription
1987+ height <- getEventSubscribedHeight parentSubd
1988+ if height == invalidHeight
1989+ then writeIORef heightRef invalidHeight
1990+ else do
1991+ modifyIORef' heightBagRef $ heightBagAdd height
1992+ modifyIORef' heightRef $ \oldHeight ->
1993+ if oldHeight == invalidHeight
1994+ then invalidHeight
1995+ else max (succHeight height) oldHeight
1996+ myHeight <- liftIO $ readIORef heightRef
1997+ currentHeight <- getCurrentHeight
1998+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1999+ occ <- if currentHeight >= myHeight -- If we should have fired by now
2000+ then if isEmpty
2001+ then return Nothing
2002+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
2003+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
2004+ return Nothing
2005+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2006+ defer $ SomeMergeInit $ do
2007+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
2008+ where
2009+ u = do
2010+ let f k newParent = do
2011+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
2012+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
2013+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
2014+ return subscription
2015+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
2016+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
2017+ liftIO $ for_ oldParents $ \oldParent -> do
2018+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2019+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2020+ return $ IntMap.elems oldParents
2021+ let s = Subscriber
2022+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2023+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2024+ defer $ updateMe a
2025+ , subscriberInvalidateHeight = \_ -> return ()
2026+ , subscriberRecalculateHeight = \_ -> return ()
2027+ }
2028+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2029+ forM_ change $ \c -> defer $ updateMe c
2030+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2031+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2032+ -- its subscription.
2033+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2034+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2035+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2036+ , occ
2037+ )
2038+
2039+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2040+
2041+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2042+fan e =
2043+ let f = Fan
2044+ { fanParent = e
2045+ , fanSubscribed = unsafeNewIORef e Nothing
2046+ }
2047+ in EventSelector $ \k -> eventFan k f
2048+
2049+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2050+runHoldInits holdInitRef dynInitRef mergeInitRef = do
2051+ holdInits <- liftIO $ readIORef holdInitRef
2052+ dynInits <- liftIO $ readIORef dynInitRef
2053+ mergeInits <- liftIO $ readIORef mergeInitRef
2054+ unless (null holdInits && null dynInits && null mergeInits) $ do
2055+ liftIO $ writeIORef holdInitRef []
2056+ liftIO $ writeIORef dynInitRef []
2057+ liftIO $ writeIORef mergeInitRef []
2058+ mapM_ initHold holdInits
2059+ mapM_ initDyn dynInits
2060+ mapM_ unSomeMergeInit mergeInits
2061+ runHoldInits holdInitRef dynInitRef mergeInitRef
2062+
2063+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2064+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2065+
2066+initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2067+initDyn (SomeDynInit d) = void $ getDynHold d
2068+
2069+newEventEnv :: IO (EventEnv x)
2070+newEventEnv = do
2071+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2072+ holdInitRef <- newIORef []
2073+ dynInitRef <- newIORef []
2074+ mergeUpdateRef <- newIORef []
2075+ mergeInitRef <- newIORef []
2076+ heightRef <- newIORef zeroHeight
2077+ toClearRef <- newIORef []
2078+ toClearIntRef <- newIORef []
2079+ toClearRootRef <- newIORef []
2080+ coincidenceInfosRef <- newIORef []
2081+ delayedRef <- newIORef IntMap.empty
2082+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2083+
2084+clearEventEnv :: EventEnv x -> IO ()
2085+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2086+ writeIORef toAssignRef []
2087+ writeIORef holdInitRef []
2088+ writeIORef dynInitRef []
2089+ writeIORef mergeUpdateRef []
2090+ writeIORef mergeInitRef []
2091+ writeIORef heightRef zeroHeight
2092+ writeIORef toClearRef []
2093+ writeIORef toClearIntRef []
2094+ writeIORef toClearRootRef []
2095+ writeIORef coincidenceInfosRef []
2096+ writeIORef delayedRef IntMap.empty
2097+
2098+-- | Run an event action outside of a frame
2099+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2100+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2101+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2102+ let go = do
2103+ result <- a
2104+ 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
2105+ return result
2106+ result <- runEventM go
2107+ toClear <- readIORef $ eventEnvClears env
2108+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2109+ toClearInt <- readIORef $ eventEnvIntClears env
2110+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2111+ toClearRoot <- readIORef $ eventEnvRootClears env
2112+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2113+ toAssign <- readIORef $ eventEnvAssignments env
2114+ toReconnectRef <- newIORef []
2115+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2116+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2117+ writeIORef vRef v
2118+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
2119+ writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2120+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2121+ writeIORef (eventEnvMergeUpdates env) []
2122+ when debugPropagate $ putStrLn "Updating merges"
2123+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2124+ when debugPropagate $ putStrLn "Updating merges done"
2125+ toReconnect <- readIORef toReconnectRef
2126+ clearEventEnv env
2127+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2128+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2129+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2130+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2131+ finalize wi
2132+ i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2133+ wi' <- mkWeakPtrWithDebug i "wi'"
2134+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2135+ writeIORef (switchSubscribedBehaviorParents subscribed) []
2136+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2137+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2138+ 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
2139+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2140+ sub <- newSubscriberSwitch subscribed
2141+ 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
2142+ {-
2143+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2144+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2145+ EventRoot _ -> "EventRoot"
2146+ EventNever -> "EventNever"
2147+ _ -> "something else"
2148+ -}
2149+ writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2150+ return oldSubscription
2151+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2152+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2153+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2154+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2155+ parentHeight <- getEventSubscribedHeight subd'
2156+ myHeight <- readIORef $ switchSubscribedHeight subscribed
2157+ when (parentHeight /= myHeight) $ do
2158+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2159+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2160+ 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
2161+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2162+ unsubscribe subscription
2163+ mapM_ invalidateCoincidenceHeight mcs
2164+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2165+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2166+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2167+ height <- calculateSwitchHeight subscribed
2168+ updateSwitchHeight height subscribed
2169+ return result
2170+
2171+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2172+
2173+{-# INLINE zeroHeight #-}
2174+zeroHeight :: Height
2175+zeroHeight = Height 0
2176+
2177+{-# INLINE invalidHeight #-}
2178+invalidHeight :: Height
2179+invalidHeight = Height (-1000)
2180+
2181+#ifdef DEBUG_CYCLES
2182+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2183+{-# INLINE invalidHeightBeingTraversed #-}
2184+invalidHeightBeingTraversed :: Height
2185+invalidHeightBeingTraversed = Height (-1001)
2186+#endif
2187+
2188+{-# INLINE succHeight #-}
2189+succHeight :: Height -> Height
2190+succHeight h@(Height a) =
2191+ if h == invalidHeight
2192+ then invalidHeight
2193+ else Height $ succ a
2194+
2195+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2196+invalidateCoincidenceHeight subscribed = do
2197+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2198+ when (oldHeight /= invalidHeight) $ do
2199+ writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2200+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2201+
2202+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2203+updateSwitchHeight new subscribed = do
2204+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
2205+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2206+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2207+ writeIORef (switchSubscribedHeight subscribed) $! new
2208+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2209+
2210+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2211+recalculateCoincidenceHeight subscribed = do
2212+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2213+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2214+ height <- calculateCoincidenceHeight subscribed
2215+ when (height /= invalidHeight) $ do
2216+ writeIORef (coincidenceSubscribedHeight subscribed) $! height
2217+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2218+
2219+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2220+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2221+
2222+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2223+calculateCoincidenceHeight subscribed = do
2224+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2225+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2226+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2227+
2228+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2229+
2230+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2231+invalidate toReconnectRef wis = do
2232+ forM_ wis $ \wi -> do
2233+ mi <- deRefWeak wi
2234+ case mi of
2235+ Nothing -> do
2236+ traceInvalidate "invalidate Dead"
2237+ return () --TODO: Should we clean this up here?
2238+ Just i -> do
2239+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2240+ case i of
2241+ InvalidatorPull p -> do
2242+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
2243+ mVal <- readIORef $ pullValue p
2244+ forM_ mVal $ \val -> do
2245+ writeIORef (pullValue p) Nothing
2246+ writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2247+ InvalidatorSwitch subscribed -> do
2248+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2249+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2250+ 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
2251+
2252+--------------------------------------------------------------------------------
2253+-- Reflex integration
2254+--------------------------------------------------------------------------------
2255+
2256+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2257+-- When we're specializing, we include this from Reflex.Class instead, because
2258+-- it needs access to these types; when we're not, we want them here, so our
2259+-- instance isn't an orphan instance.
2260+#include "SpiderTimeline.include.hs"
2261+#include "SpiderTimelineHost.include.hs"
2262+#endif
2263+
2264+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2265+unsafeNewSpiderTimelineEnv = do
2266+ lock <- newMVar ()
2267+ env <- newEventEnv
2268+#ifdef DEBUG
2269+ depthRef <- newIORef 0
2270+#endif
2271+ return $ SpiderTimelineEnv
2272+ { _spiderTimeline_lock = lock
2273+ , _spiderTimeline_eventEnv = env
2274+#ifdef DEBUG
2275+ , _spiderTimeline_depth = depthRef
2276+#endif
2277+ }
2278+
2279+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2280+-- | Create a new SpiderTimelineEnv
2281+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2282+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2283+
2284+data LocalSpiderTimeline x s
2285+
2286+instance Reifies s (SpiderTimelineEnv x) =>
2287+ HasSpiderTimeline (LocalSpiderTimeline x s) where
2288+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2289+
2290+localSpiderTimeline
2291+ :: Proxy s
2292+ -> SpiderTimelineEnv x
2293+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2294+localSpiderTimeline _ = unsafeCoerce
2295+
2296+-- | Pass a new timeline to the given function.
2297+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2298+withSpiderTimeline k = do
2299+ env <- unsafeNewSpiderTimelineEnv
2300+ reify env $ \s -> k $ localSpiderTimeline s env
2301+#endif
2302+
2303+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2304+
2305+type ComputeM = EventM
2306+
2307+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2308+
2309+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2310+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2311+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2312+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2313+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2314+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2315+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2316+ type PullM (SpiderTimeline x) = SpiderPullM x
2317+ type PushM (SpiderTimeline x) = SpiderPushM x
2318+ {-# INLINABLE never #-}
2319+ never = SpiderEvent eventNever
2320+ {-# INLINABLE constant #-}
2321+ constant = SpiderBehavior . behaviorConst
2322+ {-# INLINE push #-}
2323+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
2324+ {-# INLINE pushCheap #-}
2325+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2326+ {-# INLINABLE pull #-}
2327+ pull = SpiderBehavior . pull . coerce
2328+ {-# INLINABLE merge #-}
2329+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2330+ {-# INLINABLE fan #-}
2331+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2332+ {-# INLINABLE switch #-}
2333+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2334+ {-# INLINABLE coincidence #-}
2335+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2336+ {-# INLINABLE current #-}
2337+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2338+ {-# INLINABLE updated #-}
2339+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2340+ {-# INLINABLE unsafeBuildDynamic #-}
2341+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2342+ {-# INLINABLE unsafeBuildIncremental #-}
2343+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2344+ {-# INLINABLE mergeIncremental #-}
2345+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2346+ {-# INLINABLE mergeIncrementalWithMove #-}
2347+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2348+ {-# INLINABLE currentIncremental #-}
2349+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2350+ {-# INLINABLE updatedIncremental #-}
2351+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2352+ {-# INLINABLE incrementalToDynamic #-}
2353+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2354+ c <- readBehaviorUntracked $ dynamicCurrent i
2355+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2356+ eventCoercion Coercion = Coercion
2357+ behaviorCoercion Coercion = Coercion
2358+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2359+ {-# INLINABLE mergeIntIncremental #-}
2360+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2361+ {-# INLINABLE fanInt #-}
2362+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2363+#endif
2364+
2365+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2366+
2367+data SpiderEventHandle x a = SpiderEventHandle
2368+ { spiderEventHandleSubscription :: EventSubscription x
2369+ , spiderEventHandleValue :: IORef (Maybe a)
2370+ }
2371+
2372+instance MonadRef (EventM x) where
2373+ type Ref (EventM x) = Ref IO
2374+ {-# INLINABLE newRef #-}
2375+ {-# INLINABLE readRef #-}
2376+ {-# INLINABLE writeRef #-}
2377+ newRef = liftIO . newRef
2378+ readRef = liftIO . readRef
2379+ writeRef r a = liftIO $ writeRef r a
2380+
2381+instance MonadAtomicRef (EventM x) where
2382+ {-# INLINABLE atomicModifyRef #-}
2383+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
2384+
2385+-- | The monad for actions that manipulate a Spider timeline identified by @x@
2386+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2387+
2388+instance Monad (SpiderHost x) where
2389+ {-# INLINABLE (>>=) #-}
2390+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2391+ {-# INLINABLE (>>) #-}
2392+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2393+ {-# INLINABLE return #-}
2394+ return x = SpiderHost $ return x
2395+ {-# INLINABLE fail #-}
2396+ fail s = SpiderHost $ fail s
2397+
2398+-- | Run an action affecting the global Spider timeline; this will be guarded by
2399+-- a mutex for that timeline
2400+runSpiderHost :: SpiderHost Global a -> IO a
2401+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2402+
2403+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2404+-- | Run an action affecting a given Spider timeline; this will be guarded by a
2405+-- mutex for that timeline
2406+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2407+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2408+#endif
2409+
2410+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2411+
2412+instance Monad (SpiderHostFrame x) where
2413+ {-# INLINABLE (>>=) #-}
2414+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2415+ {-# INLINABLE (>>) #-}
2416+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2417+ {-# INLINABLE return #-}
2418+ return x = SpiderHostFrame $ return x
2419+ {-# INLINABLE fail #-}
2420+ fail s = SpiderHostFrame $ fail s
2421+
2422+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2423+newEventWithTriggerIO f = do
2424+ es <- newFanEventWithTriggerIO $ \Refl -> f
2425+ return $ select es Refl
2426+
2427+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2428+newFanEventWithTriggerIO f = do
2429+ occRef <- newIORef DMap.empty
2430+ subscribedRef <- newIORef DMap.empty
2431+ let !r = Root
2432+ { rootOccurrence = occRef
2433+ , rootSubscribed = subscribedRef
2434+ , rootInit = f
2435+ }
2436+ return $ EventSelector $ \k -> eventRoot k r
2437+
2438+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2439+
2440+instance MonadRef (SpiderHost x) where
2441+ type Ref (SpiderHost x) = Ref IO
2442+ newRef = SpiderHost . newRef
2443+ readRef = SpiderHost . readRef
2444+ writeRef r = SpiderHost . writeRef r
2445+
2446+instance MonadAtomicRef (SpiderHost x) where
2447+ atomicModifyRef r = SpiderHost . atomicModifyRef r
2448+
2449+instance MonadRef (SpiderHostFrame x) where
2450+ type Ref (SpiderHostFrame x) = Ref IO
2451+ newRef = SpiderHostFrame . newRef
2452+ readRef = SpiderHostFrame . readRef
2453+ writeRef r = SpiderHostFrame . writeRef r
2454+
2455+instance MonadAtomicRef (SpiderHostFrame x) where
2456+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2457+
2458+instance PrimMonad (SpiderHostFrame x) where
2459+ type PrimState (SpiderHostFrame x) = PrimState IO
2460+ primitive = SpiderHostFrame . EventM . primitive
src/Reflex/Spider/SpiderTimeline.include.hsnew file+155
@@ -0,0 +1,155 @@
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+ {-# INLINABLE headE #-}
22+ headE = R.slowHeadE
23+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
24+
25+instance (
26+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
27+ x ~ Global
28+#endif
29+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
30+ {-# INLINABLE sample #-}
31+ sample = coerce . readBehaviorTracked . unSpiderBehavior
32+
33+instance (
34+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
35+ x ~ Global
36+#else
37+ HasSpiderTimeline x
38+#endif
39+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
40+ {-# INLINABLE sample #-}
41+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
42+
43+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
44+ {-# INLINABLE hold #-}
45+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
46+ {-# INLINABLE holdDyn #-}
47+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
48+ {-# INLINABLE holdIncremental #-}
49+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
50+ {-# INLINABLE buildDynamic #-}
51+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
52+ {-# INLINABLE headE #-}
53+ headE = R.slowHeadE
54+-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
55+
56+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
57+ {-# INLINE return #-}
58+ return = pure
59+ {-# INLINE (>>=) #-}
60+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
61+ {-# INLINE (>>) #-}
62+ _ >> y = y
63+ {-# INLINE fail #-}
64+ fail _ = error "Dynamic does not support 'fail'"
65+
66+{-# INLINABLE newJoinDyn #-}
67+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
68+newJoinDyn d =
69+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
70+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
71+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
72+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
73+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
74+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
75+
76+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
77+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
78+ x <$ _ = pure x
79+
80+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
81+ pure = SpiderDynamic . dynamicConst
82+#if MIN_VERSION_base(4,10,0)
83+ liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)
84+#endif
85+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
86+ _ *> b = b
87+ a <* _ = a --TODO: The semantics of *>, <*, and <$ might not be quite right - they drop changes
88+
89+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
90+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
91+
92+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
93+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
94+
95+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
96+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
97+
98+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
99+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
100+
101+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
102+ {-# INLINABLE hold #-}
103+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
104+ {-# INLINABLE holdDyn #-}
105+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
106+ {-# INLINABLE holdIncremental #-}
107+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
108+ {-# INLINABLE buildDynamic #-}
109+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
110+ {-# INLINABLE headE #-}
111+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
112+
113+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
114+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
115+
116+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
117+ {-# INLINABLE hold #-}
118+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
119+ {-# INLINABLE holdDyn #-}
120+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
121+ {-# INLINABLE holdIncremental #-}
122+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
123+ {-# INLINABLE buildDynamic #-}
124+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
125+ {-# INLINABLE headE #-}
126+ headE = R.slowHeadE
127+-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
128+
129+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
130+ {-# INLINABLE sample #-}
131+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
132+
133+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
134+ {-# INLINABLE sample #-}
135+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
136+
137+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
138+ {-# INLINABLE hold #-}
139+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
140+ {-# INLINABLE holdDyn #-}
141+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
142+ {-# INLINABLE holdIncremental #-}
143+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
144+ {-# INLINABLE buildDynamic #-}
145+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
146+ {-# INLINABLE headE #-}
147+ headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
148+
149+--------------------------------------------------------------------------------
150+-- Deprecated items
151+--------------------------------------------------------------------------------
152+
153+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
154+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
155+type SpiderEnv = SpiderTimeline
src/Reflex/Spider/SpiderTimelineHost.include.hsnew file+57
@@ -0,0 +1,57 @@
1+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2+ {-# INLINABLE subscribeEvent #-}
3+ subscribeEvent e = SpiderHostFrame $ do
4+ --TODO: Unsubscribe eventually (manually and/or with weak ref)
5+ val <- liftIO $ newIORef Nothing
6+ subscription <- subscribe (unSpiderEvent e) $ Subscriber
7+ { subscriberPropagate = \a -> do
8+ liftIO $ writeIORef val $ Just a
9+ scheduleClear val
10+ , subscriberInvalidateHeight = \_ -> return ()
11+ , subscriberRecalculateHeight = \_ -> return ()
12+ }
13+ return $ SpiderEventHandle
14+ { spiderEventHandleSubscription = subscription
15+ , spiderEventHandleValue = val
16+ }
17+
18+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
19+ type EventTrigger (SpiderTimeline x) = RootTrigger x
20+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x
21+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x
22+
23+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
24+ {-# NOINLINE readEvent #-}
25+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
26+ result <- readIORef $ spiderEventHandleValue h
27+ touch h
28+ return result
29+
30+instance (
31+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
32+ x ~ Global
33+#endif
34+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
35+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
36+ newFanEventWithTrigger f = SpiderHost $ lift $ do
37+ es <- newFanEventWithTriggerIO f
38+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
39+
40+instance (
41+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
42+ x ~ Global
43+#endif
44+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
45+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
46+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
47+ es <- newFanEventWithTriggerIO f
48+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
49+
50+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
51+ {-# INLINABLE subscribeEvent #-}
52+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
53+
54+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
55+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
56+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
57+ runHostFrame = runFrame . runSpiderHostFrame
src/Reflex/Time.hsnew file+240
@@ -0,0 +1,240 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE RecursiveDo #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE CPP #-}
7+#ifdef USE_TEMPLATE_HASKELL
8+{-# LANGUAGE TemplateHaskell #-}
9+#endif
10+{-# LANGUAGE TypeFamilies #-}
11+module Reflex.Time where
12+
13+import Reflex.Class
14+import Reflex.Dynamic
15+import Reflex.PerformEvent.Class
16+import Reflex.PostBuild.Class
17+import Reflex.TriggerEvent.Class
18+
19+import Control.Concurrent
20+import qualified Control.Concurrent.Thread.Delay as Concurrent
21+import Control.Lens hiding ((|>))
22+import Control.Monad
23+import Control.Monad.Fix
24+import Control.Monad.IO.Class
25+import Data.Align
26+import Data.Fixed
27+import Data.Sequence (Seq, (|>))
28+import qualified Data.Sequence as Seq
29+import Data.These
30+import Data.Time.Clock
31+import Data.Typeable
32+import System.Random
33+
34+data TickInfo
35+ = TickInfo { _tickInfo_lastUTC :: UTCTime
36+ -- ^ UTC time immediately after the last tick.
37+ , _tickInfo_n :: Integer
38+ -- ^ Number of time periods since t0
39+ , _tickInfo_alreadyElapsed :: NominalDiffTime
40+ -- ^ Amount of time already elapsed in the current tick period.
41+ }
42+ deriving (Eq, Ord, Show, Typeable)
43+
44+-- | Special case of tickLossyFrom that uses the post-build event to start the
45+-- tick thread.
46+tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
47+tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
48+
49+-- | Send events over time with the given basis time and interval
50+-- If the system starts running behind, occurrences will be dropped rather than buffered
51+-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time
52+tickLossyFrom
53+ :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
54+ => NominalDiffTime
55+ -> UTCTime
56+ -> Event t a
57+ -- ^ Event that starts a tick generation thread. Usually you want this to
58+ -- be something like the result of getPostBuild that only fires once. But
59+ -- there could be uses for starting multiple timer threads.
60+ -> m (Event t TickInfo)
61+tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
62+
63+-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
64+tickLossyFrom'
65+ :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
66+ => Event t (NominalDiffTime, UTCTime)
67+ -- ^ Event that starts a tick generation thread. Usually you want this to
68+ -- be something like the result of getPostBuild that only fires once. But
69+ -- there could be uses for starting multiple timer threads.
70+ -> m (Event t TickInfo)
71+tickLossyFrom' e = do
72+ rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]
73+ return $ fst <$> result
74+ where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do
75+ tick <- uncurry getCurrentTick pair
76+ Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000
77+ cb (tick, pair)
78+
79+clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)
80+clockLossy dt t0 = do
81+ initial <- liftIO $ getCurrentTick dt t0
82+ e <- tickLossy dt t0
83+ holdDyn initial e
84+
85+getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
86+getCurrentTick dt t0 = do
87+ t <- getCurrentTime
88+ let offset = t `diffUTCTime` t0
89+ (n, alreadyElapsed) = offset `divMod'` dt
90+ return $ TickInfo t n alreadyElapsed
91+
92+-- | Delay an Event's occurrences by a given amount in seconds.
93+delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
94+delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
95+ Concurrent.delay $ ceiling $ dt * 1000000
96+ cb a
97+
98+-- | Send events with Poisson timing with the given basis and rate
99+-- Each occurence of the resulting event will contain the index of
100+-- the current interval, with 0 representing the basis time
101+poissonLossyFrom
102+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
103+ => g
104+ -> Double
105+ -- ^ Poisson event rate (Hz)
106+ -> UTCTime
107+ -- ^ Baseline time for events
108+ -> Event t a
109+ -- ^ Event that starts a tick generation thread. Usually you want this to
110+ -- be something like the result of getPostBuild that only fires once. But
111+ -- there could be uses for starting multiple timer threads.
112+ -- Start sending events in response to the event parameter.
113+ -> m (Event t TickInfo)
114+poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
115+
116+
117+-- | Send events with Poisson timing with the given basis and rate
118+-- Each occurence of the resulting event will contain the index of
119+-- the current interval, with 0 representing the basis time.
120+-- Automatically begin sending events when the DOM is built
121+poissonLossy
122+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
123+ => g
124+ -> Double
125+ -- ^ Poisson event rate (Hz)
126+ -> UTCTime
127+ -- ^ Baseline time for events
128+ -> m (Event t TickInfo)
129+poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
130+
131+-- | Send events with inhomogeneous Poisson timing with the given basis
132+-- and variable rate. Provide a maxRate that you expect to support.
133+inhomogeneousPoissonFrom
134+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
135+ => g
136+ -> Behavior t Double
137+ -> Double
138+ -> UTCTime
139+ -> Event t a
140+ -> m (Event t TickInfo)
141+inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
142+
143+ -- Create a thread for producing homogeneous poisson events
144+ -- along with random Doubles (usage of Double's explained below)
145+ ticksWithRateRand <- performEventAsync $
146+ fmap callAtNextInterval e
147+
148+ -- Filter homogeneous events according to associated
149+ -- random values and the current rate parameter
150+ return $ attachWithMaybe filterFun rate ticksWithRateRand
151+
152+ where
153+
154+ -- Inhomogeneous poisson processes are built from faster
155+ -- homogeneous ones by randomly dropping events from the
156+ -- fast process. For each fast homogeneous event, choose
157+ -- a uniform random sample from (0, rMax). If the
158+ -- inhomogeneous rate at this moment is greater than the
159+ -- random sample, then keep this event, otherwise drop it
160+ filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo
161+ filterFun r (tInfo, p)
162+ | r >= p = Just tInfo
163+ | otherwise = Nothing
164+
165+ callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
166+
167+ go tTargetLast lastGen cb lastN = do
168+ t <- getCurrentTime
169+
170+ -- Generate random numbers for this poisson interval (u)
171+ -- and sample-retention likelihood (p)
172+ let (u, nextGen) = randomR (0,1) lastGen
173+ (p :: Double, nextGen') = randomR (0,maxRate) nextGen
174+
175+ -- Inter-event interval is drawn from exponential
176+ -- distribution accourding to u
177+ let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime
178+ nEvents = lastN + 1
179+ alreadyElapsed = diffUTCTime t tTargetLast
180+ tTarget = addUTCTime dt tTargetLast
181+ thisDelay = realToFrac $ diffUTCTime tTarget t :: Double
182+ Concurrent.delay $ ceiling $ thisDelay * 1000000
183+ _ <- cb (TickInfo t nEvents alreadyElapsed, p)
184+ go tTarget nextGen' cb nEvents
185+
186+-- | Send events with inhomogeneous Poisson timing with the given basis
187+-- and variable rate. Provide a maxRate that you expect to support
188+inhomogeneousPoisson
189+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
190+ => g
191+ -> Behavior t Double
192+ -> Double
193+ -> UTCTime
194+ -> m (Event t TickInfo)
195+inhomogeneousPoisson rnd rate maxRate t0 =
196+ inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
197+
198+-- | Block occurrences of an Event until the given number of seconds elapses without
199+-- the Event firing, at which point the last occurrence of the Event will fire.
200+debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
201+debounce dt e = do
202+ n :: Dynamic t Integer <- count e
203+ let tagged = attachPromptlyDynWith (,) n e
204+ delayed <- delay dt tagged
205+ return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
206+
207+-- | When the given 'Event' occurs, wait the given amount of time and collect
208+-- all occurrences during that time. Then, fire the output 'Event' with the
209+-- collected output.
210+batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
211+batchOccurrences t newValues = do
212+ let f s x = (Just newState, out)
213+ where newState = case x of
214+ This a -> s |> a
215+ That _ -> mempty
216+ These a _ -> Seq.singleton a
217+ out = case x of
218+ This _ -> if Seq.null s then Just () else Nothing
219+ That _ -> Nothing
220+ These _ _ -> Just ()
221+ rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed
222+ delayed <- delay t toDelay
223+ return $ tag buffer delayed
224+
225+#ifdef USE_TEMPLATE_HASKELL
226+makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
227+#else
228+tickInfo_lastUTC :: Lens' TickInfo UTCTime
229+tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1
230+{-# INLINE tickInfo_lastUTC #-}
231+
232+tickInfo_n :: Lens' TickInfo Integer
233+tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2
234+{-# INLINE tickInfo_n #-}
235+
236+tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime
237+tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3
238+{-# INLINE tickInfo_alreadyElapsed #-}
239+#endif
240+
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+139
@@ -0,0 +1,139 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE RankNTypes #-}
7+
8+import Control.Lens
9+import Control.Monad.Fix
10+import Data.Align
11+import Data.AppendMap (AppendMap)
12+import qualified Data.AppendMap as AMap
13+import Data.Functor.Misc
14+import Data.Map (Map)
15+import qualified Data.Map as Map
16+import Data.Semigroup
17+import Data.These
18+
19+import Reflex
20+import Reflex.Patch.MapWithMove
21+import Test.Run
22+
23+newtype MyQuery = MyQuery SelectedCount
24+ deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
25+
26+instance Query MyQuery where
27+ type QueryResult MyQuery = ()
28+ crop _ _ = ()
29+
30+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
31+ type QueryResult (Selector k a) = Selector k (QueryResult a)
32+ crop q r = undefined
33+
34+newtype Selector k a = Selector { unSelector :: AppendMap k a }
35+ deriving (Show, Read, Eq, Ord, Functor)
36+
37+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
38+ (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
39+ where
40+ f = alignWith $ \case
41+ This x -> Just x
42+ That y -> Just y
43+ These x y ->
44+ let z = x `mappend` y
45+ in if z == mempty then Nothing else Just z
46+
47+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
48+ mempty = Selector AMap.empty
49+ mappend = (<>)
50+
51+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
52+ negateG = fmap negateG
53+
54+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
55+
56+main :: IO ()
57+main = do
58+ [0, 1, 1, 0] <- fmap (map fst . concat) $
59+ runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
60+ [ That (), This (), That () ]
61+ [0, 1, 1, 0] <- fmap (map fst . concat) $
62+ runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
63+ [ That (), This (), That () ]
64+ [0, 1, 1, 0] <- fmap (map fst . concat) $
65+ runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
66+ [ That (), This (), That () ]
67+ return ()
68+
69+testQueryT :: (Reflex t, MonadFix m)
70+ => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
71+ -> AppIn t () (These () ())
72+ -> m (AppOut t Int Int)
73+testQueryT w (AppIn _ pulse) = do
74+ let replace = fmapMaybe (^? here) pulse
75+ increment = fmapMaybe (^? there) pulse
76+ (_, q) <- runQueryT (w replace increment) $ pure mempty
77+ let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
78+ return $ AppOut
79+ { _appOut_behavior = current qDyn
80+ , _appOut_event = updated qDyn
81+ }
82+
83+testRunWithReplace :: ( Reflex t
84+ , MonadAdjust t m
85+ , MonadHold t m
86+ , MonadFix m
87+ , MonadQuery t (Selector Int MyQuery) m)
88+ => Event t ()
89+ -> Event t ()
90+ -> m ()
91+testRunWithReplace replace increment = do
92+ let w = do
93+ n <- count increment
94+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
95+ _ <- runWithReplace w $ w <$ replace
96+ return ()
97+
98+testSequenceDMapWithAdjust :: ( Reflex t
99+ , MonadAdjust t m
100+ , MonadHold t m
101+ , MonadFix m
102+ , MonadQuery t (Selector Int MyQuery) m)
103+ => Event t ()
104+ -> Event t ()
105+ -> m ()
106+testSequenceDMapWithAdjust replace increment = do
107+ _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
108+ n <- count increment
109+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
110+ return ()
111+
112+testSequenceDMapWithAdjustWithMove :: ( Reflex t
113+ , MonadAdjust t m
114+ , MonadHold t m
115+ , MonadFix m
116+ , MonadQuery t (Selector Int MyQuery) m)
117+ => Event t ()
118+ -> Event t ()
119+ -> m ()
120+testSequenceDMapWithAdjustWithMove replace increment = do
121+ _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
122+ n <- count increment
123+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
124+ return ()
125+
126+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))
127+listHoldWithKey m0 m' f = do
128+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
129+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
130+ (a0, a') <- sequenceDMapWithAdjust dm0 dm'
131+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
132+
133+
134+-- scam it out to test traverseDMapWithAdjustWithMove
135+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))
136+listHoldWithKeyWithMove m0 m' f = do
137+ (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
138+ incrementalToDynamic <$> holdIncremental n0 n'
139+-- -}
test/Reflex/Bench/Focused.hsnew file+369
@@ -0,0 +1,369 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecursiveDo #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TupleSections #-}
10+{-# LANGUAGE TypeSynonymInstances #-}
11+
12+module Reflex.Bench.Focused where
13+
14+import Reflex
15+import Reflex.TestPlan
16+
17+import Control.Applicative
18+import Control.Monad
19+import Control.Monad.Fix
20+import Control.Monad.Identity
21+import Data.Traversable (for, traverse)
22+
23+import qualified Data.Dependent.Map as DMap
24+import Data.Map (Map)
25+import qualified Data.Map as Map
26+import Data.Maybe
27+
28+import Data.Functor.Misc
29+
30+import Data.List
31+import Data.List.Split
32+import Data.Tuple
33+
34+import Data.Monoid
35+import Data.Word
36+
37+import Control.DeepSeq
38+
39+import Prelude hiding (concat, sum)
40+
41+
42+mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
43+mergeTree n es | length es <= n = sum' es
44+ | otherwise = mergeTree n subTrees
45+ where
46+ merges = chunksOf n es
47+ subTrees = map sum' merges
48+ sum' = fmap sum . mconcat . fmap (fmap (:[]) )
49+
50+mergeListDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
51+mergeListDyn = mconcat . fmap (fmap pure)
52+
53+mergeTreeDyn :: (Num a, Reflex t) => Int -> [Dynamic t a] -> Dynamic t a
54+mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
55+ | otherwise = mergeTreeDyn n $ fmap sumDyns merges
56+ where
57+ merges = chunksOf n dyns
58+ sumDyns = fmap sum . mergeListDyn
59+
60+
61+
62+-- N events all firing for N frames
63+continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
64+continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
65+
66+-- Fire N events once every P frames for total N frames (interspersed evenly)
67+occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
68+occasional n period frames = traverse plan $ zipWith occs [1..] phases
69+ where
70+ phases = take (fromIntegral n) $ concat (repeat [1..period])
71+ occs i phase = (, i) <$> [1, phase+1..frames]
72+
73+
74+
75+-- Event which never fires (but isn't 'never')
76+never' :: TestPlan t m => m (Event t Word)
77+never' = plan []
78+
79+
80+-- Event which fires once on first frame
81+event :: TestPlan t m => m (Event t Word)
82+event = plan [(1, 0)]
83+
84+-- Event which fires constantly over N frames
85+events :: TestPlan t m => Word -> m (Event t Word)
86+events n = plan $ (\i -> (i, i)) <$> [1..n]
87+
88+
89+-- N events all originating from one event
90+fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
91+fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
92+
93+
94+-- Make a fan using the value in the event converting it to a singleton Map
95+-- use a fan of size n (key is the value mod n)
96+fanMerge :: Reflex t => Word -> Event t Word -> Event t Word
97+fanMerge n e = leftmost $ s <$> [0..n - 1] where
98+ s k = select f (Const2 k)
99+ f = fan (toMap <$> e)
100+ toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)
101+
102+-- Dumb version of the above using simple fmapMaybe to filter
103+fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word
104+fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where
105+ s k = flip fmapMaybe e $ \j -> if k == j `mod` n
106+ then Just k
107+ else Nothing
108+
109+
110+
111+-- Create an Event with a Map which is dense to size N
112+denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
113+denseMap n = plan [(1, m)] where
114+ m = Map.fromList $ zip [1..n] [1..n]
115+
116+iter :: (a -> a) -> Word -> a -> a
117+iter _ 0 a = a
118+iter f n a = iter f (n - 1) (f a)
119+
120+iterM :: Monad m => (a -> m a) -> Word -> a -> m a
121+iterM _ 0 a = return a
122+iterM f n a = iterM f (n - 1) =<< f a
123+
124+fmapChain :: (Functor f) => Word -> f Word -> f Word
125+fmapChain = iter (fmap (+1))
126+
127+mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
128+mapDynChain = iterM (return . fmap (+1))
129+
130+joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131+joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
132+
133+combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134+combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
135+
136+pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
137+pingPong e1 e2 = do
138+ rec
139+ d <- foldDyn (const swap) (e1, e2) e
140+ let e = switch (fst <$> current d)
141+ return e
142+
143+switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
144+switchFactors 0 e = return e
145+switchFactors i e = do
146+ b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
147+ switchFactors (i - 1) (switch b)
148+
149+
150+switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
151+switchChain = iterM (\e -> pingPong e ((+1) <$> e))
152+
153+
154+switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
155+switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))
156+
157+switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
158+switchPromptlyChain = iterM $ \e ->
159+ switchPromptlyDyn <$> holdDyn e (e <$ e)
160+
161+
162+coinChain :: Reflex t => Word -> Event t Word -> Event t Word
163+coinChain = iter $ \e -> coincidence (e <$ e)
164+
165+fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
166+fanMergeChain width = iter $ fanMerge width
167+
168+fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
169+fmapFanMergeChain width = iter $ fmapFanMerge width
170+
171+-- | Data type for a collection (a map) which is updated by providing differences
172+data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
173+
174+-- This will hopefully become a primitive (faster!)
175+switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
176+switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
177+
178+-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
179+-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)
180+
181+switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a))
182+switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges
183+ where joinMap m = traverse sample =<< sample m
184+
185+-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
186+holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
187+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes
188+
189+ where
190+ modify k Nothing items = Map.delete k items
191+ modify k (Just item) items = Map.insert k item items
192+
193+
194+-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
195+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
196+holdMap = (current <$>) . holdMapDyn
197+
198+
199+increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
200+increasingMerge xs = do
201+ e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
202+ return (UpdatedMap Map.empty e)
203+ where
204+ reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
205+
206+decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
207+decreasingMerge xs = do
208+ e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
209+ return (UpdatedMap initial e)
210+ where
211+ initial = Map.fromList $ zip [1..] xs
212+ reset = Just <$> initial
213+
214+modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
215+modifyMerge xs = do
216+ e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
217+ return (UpdatedMap initial e)
218+ where
219+ initial = Map.fromList $ zip [1..] xs
220+
221+
222+countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
223+countMany = traverse (fmap current . count)
224+
225+countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
226+countManyDyn = traverse count
227+
228+
229+-- Given a function which creates a sub-network (from a single event)
230+-- Create a plan which uses a switch to substitute it
231+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
232+switches numFrames f = do
233+ es <- events numFrames
234+ switch <$> hold never (makeEvents es)
235+
236+ where
237+ makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
238+
239+
240+
241+-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
242+-- the other, which we're only interested in time for running frames
243+subscribing :: Word -> Word -> [(String, TestCase)]
244+subscribing n frames =
245+ [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n
246+ , testSub "fanMerge" $ return . fanMerge n
247+ , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n
248+ , testSub "fmapChain" $ return . fmapChain n
249+ , testSub "switchChain" $ switchChain n
250+ , testSub "switchPromptlyChain" $ switchPromptlyChain n
251+ , testSub "switchFactors" $ switchFactors n
252+ , testSub "coincidenceChain" $ return . coinChain n
253+ ]
254+
255+ where
256+ testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
257+ testSub name test = testE name (switches frames test)
258+
259+-- Set of benchmark to test specifically merging dynamic collections
260+-- a pattern which occurs frequently in reflex-dom collections
261+merging :: Word -> [(String, TestCase)]
262+merging n =
263+ [ testE "static events" $ mergeList <$> sparse
264+ , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
265+ , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
266+ , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
267+
268+ , testB "static behaviors" $ pull . traverse sample <$> counters
269+ , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
270+ , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
271+ , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
272+
273+
274+ -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse
275+ -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse
276+ -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse
277+ ]
278+
279+ where
280+ sparse :: TestPlan t m => m [Event t Word]
281+ sparse = fmap (fmap (+1)) <$> occasional n 8 n
282+
283+ counters :: TestPlan t m => m [Behavior t Int]
284+ counters = countMany =<< sparse
285+
286+
287+
288+fans :: Word -> [(String, TestCase)]
289+fans n =
290+ [ testE "fanMapChain" $ fanMergeChain n 10 <$> e
291+ , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e
292+
293+ , testE "fanMerge " $ fanMerge n <$> events n
294+
295+ , testE "fmapFanMerge " $ fmapFanMerge n <$> events n
296+ , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])
297+
298+ ]
299+ where
300+
301+ e :: TestPlan t m => m (Event t Word)
302+ e = events 100
303+
304+
305+
306+
307+dynamics :: Word -> [(String, TestCase)]
308+dynamics n =
309+ [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
310+ , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
311+ , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
312+ , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
313+ , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
314+ , testE "mergeDyn" $ fmap (updated . fmap sum . mergeListDyn) sparse
315+ ] where
316+
317+ d :: TestPlan t m => m (Dynamic t Word)
318+ d = count =<< events 10
319+
320+ sparse, dense :: TestPlan t m => m [Dynamic t Int]
321+ sparse = countManyDyn =<< occasional n 8 16
322+ dense = countManyDyn =<< continuous n 2
323+
324+
325+firing :: Word -> [(String, TestCase)]
326+firing n =
327+ [ testE "fmapChain" $ fmapChain n <$> e
328+ , testE "switchChain2" $ switchChain2 n =<< e
329+ , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
330+ , testE "switchFactors" $ switchFactors n =<< e
331+ , testE "coincidenceChain" $ coinChain n <$> e
332+
333+ , testE "dense mergeTree" $ mergeTree 8 <$> dense
334+ , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
335+
336+ -- Triggers test failure in Spider
337+ --, testE "runFrame" $ events n
338+
339+ , testB "sum counters" $ do
340+ counts <- counters
341+ return $ pull $ sum <$> traverse sample counts
342+
343+ , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4)
344+ , testB "pullChain2" $ do
345+ es <- events 4
346+ e' <- plan [(0, ())]
347+
348+ b <- hold (constant 0) $
349+ pushAlways (const $ fmapChain n <$> hold 0 es) e'
350+
351+ return (join b)
352+ , testB "counters/pullTree" $ mergeTree 8 <$> counters
353+
354+ ]
355+ where
356+ e :: TestPlan t m => m (Event t Word)
357+ e = events 10
358+
359+ dense, sparse :: TestPlan t m => m [Event t Word]
360+ dense = continuous n 2
361+ sparse = occasional n 8 16
362+
363+ counters :: TestPlan t m => m [Behavior t Int]
364+ counters = countMany =<< sparse
365+
366+
367+
368+
369+
test/Reflex/Plan/Pure.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+
9+module Reflex.Plan.Pure where
10+
11+import Reflex
12+import Reflex.Pure
13+import Reflex.TestPlan
14+
15+import Control.Applicative
16+import Control.Monad.Fix
17+import Control.Monad.State
18+import Data.IntMap (IntMap)
19+import qualified Data.IntMap as IntMap
20+import Data.IntSet (IntSet)
21+import qualified Data.IntSet as IntSet
22+
23+import Data.Bifunctor
24+import Data.Maybe
25+import Data.Monoid
26+import Prelude
27+
28+
29+mapToPureEvent :: IntMap a -> Event (Pure Int) a
30+mapToPureEvent m = Event $ flip IntMap.lookup m
31+
32+type TimeM = (->) Int
33+newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix)
34+
35+liftPlan :: TimeM a -> PurePlan a
36+liftPlan = PurePlan . lift
37+
38+instance MonadHold (Pure Int) PurePlan where
39+ hold initial = liftPlan . hold initial
40+ holdDyn initial = liftPlan . holdDyn initial
41+ holdIncremental initial = liftPlan . holdIncremental initial
42+ buildDynamic getInitial = liftPlan . buildDynamic getInitial
43+ headE = liftPlan . headE
44+
45+instance MonadSample (Pure Int) PurePlan where
46+ sample = liftPlan . sample
47+
48+
49+instance TestPlan (Pure Int) PurePlan where
50+ plan occs = do
51+ PurePlan . modify $ IntSet.union (IntMap.keysSet m)
52+ return $ mapToPureEvent m
53+ where m = IntMap.fromList (first fromIntegral <$> occs)
54+
55+runPure :: PurePlan a -> (a, IntSet)
56+runPure (PurePlan p) = runStateT p mempty $ 0
57+
58+relavantTimes :: IntSet -> IntSet
59+relavantTimes occs = IntSet.fromList [0..l + 1]
60+ where l = fromMaybe 0 (fst <$> IntSet.maxView occs)
61+
62+testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a
63+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)
64+
65+testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)
66+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)
67+
68+
69+
70+
71+
72+
test/Reflex/Plan/Reflex.hsnew file+135
@@ -0,0 +1,135 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Reflex.Plan.Reflex
12+ ( TestPlan(..)
13+ , runPlan
14+ , Plan (..)
15+ , Schedule
16+ , Firing (..)
17+ , MonadIORef
18+
19+
20+ , readSchedule
21+ , readSchedule_
22+ , testSchedule
23+ , readEvent'
24+ , makeDense
25+
26+ , runTestE
27+ , runTestB
28+
29+ ) where
30+
31+import Reflex.Class
32+import Reflex.Host.Class
33+import Reflex.TestPlan
34+
35+import Control.Applicative
36+import Control.Monad
37+import Control.Monad.Identity
38+import Control.Monad.State.Strict
39+
40+import Control.Monad.Ref
41+import Data.Dependent.Sum (DSum (..))
42+import qualified Data.IntMap.Strict as IntMap
43+import Data.Maybe
44+import Data.Monoid
45+import Data.Traversable (sequenceA, traverse)
46+
47+import Control.DeepSeq
48+import Control.Exception
49+import Data.IntMap.Strict (IntMap)
50+import Data.IORef
51+import System.Mem
52+
53+-- Note: this import must come last to silence warnings from AMP
54+import Prelude
55+
56+type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)
57+
58+data Firing t where
59+ Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t
60+
61+
62+type Schedule t = IntMap [Firing t]
63+
64+-- Implementation of a TestPlan in terms of ReflexHost
65+newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)
66+
67+deriving instance ReflexHost t => Functor (Plan t)
68+deriving instance ReflexHost t => Applicative (Plan t)
69+deriving instance ReflexHost t => Monad (Plan t)
70+
71+deriving instance ReflexHost t => MonadSample t (Plan t)
72+deriving instance ReflexHost t => MonadHold t (Plan t)
73+deriving instance ReflexHost t => MonadFix (Plan t)
74+
75+
76+instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
77+ plan occurances = Plan $ do
78+ (e, ref) <- newEventWithTriggerRef
79+ modify (IntMap.unionWith mappend (firings ref))
80+ return e
81+
82+ where
83+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)
84+ makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
85+
86+
87+firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
88+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
89+
90+runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t)
91+runPlan (Plan p) = runHostFrame $ runStateT p mempty
92+
93+
94+makeDense :: Schedule t -> Schedule t
95+makeDense s = fromMaybe (emptyRange 0) $ do
96+ (end, _) <- fst <$> IntMap.maxViewWithKey s
97+ return $ IntMap.union s (emptyRange end)
98+ where
99+ emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))
100+
101+
102+-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
103+-- after the last event)
104+-- performGC is called at each frame to test for GC issues
105+testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
106+testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
107+
108+readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
109+readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
110+
111+readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m ()
112+readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule
113+
114+triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a
115+triggerFrame readResult _ occs = do
116+ triggers <- catMaybes <$> traverse firingTrigger occs
117+ liftIO . evaluate . force =<< fireEventsAndRead triggers readResult
118+
119+readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
120+readEvent' = readEvent >=> sequenceA
121+
122+
123+-- Convenience functions for running tests producing Events/Behaviors
124+runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a)
125+runTestB p = do
126+ (b, s) <- runPlan p
127+ testSchedule s $ sample b
128+
129+runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a))
130+runTestE p = do
131+ (e, s) <- runPlan p
132+ h <- subscribeEvent e
133+ testSchedule s (readEvent' h)
134+
135+
test/Reflex/Test.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+
8+module Reflex.Test
9+ ( testAgreement
10+ , compareResult
11+ , runTests
12+
13+ , module Reflex.TestPlan
14+
15+ ) where
16+
17+import Reflex.Spider
18+
19+import Reflex.TestPlan
20+
21+import Reflex.Plan.Pure
22+import Reflex.Plan.Reflex
23+
24+import Control.Monad
25+import Data.Monoid
26+
27+import Data.IntMap (IntMap)
28+
29+--import Data.Foldable
30+import System.Exit
31+
32+import Prelude
33+
34+
35+testAgreement :: TestCase -> IO Bool
36+testAgreement (TestE p) = do
37+ spider <- runSpiderHost $ runTestE p
38+ let results = [("spider", spider)]
39+
40+ compareResult results (testEvent $ runPure p)
41+
42+testAgreement (TestB p) = do
43+ spider <- runSpiderHost $ runTestB p
44+ let results = [("spider", spider)]
45+
46+ compareResult results (testBehavior $ runPure p)
47+
48+
49+compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool
50+compareResult results expected = fmap and $ forM results $ \(name, r) -> do
51+
52+ when (r /= expected) $ do
53+ putStrLn ("Got: " ++ show (name, r))
54+ putStrLn ("Expected: " ++ show expected)
55+ return (r == expected)
56+
57+
58+runTests :: [(String, TestCase)] -> IO ()
59+runTests testCases = do
60+ results <- forM testCases $ \(name, test) -> do
61+ putStrLn $ "Test: " <> name
62+ testAgreement test
63+ exitWith $ if and results
64+ then ExitSuccess
65+ else ExitFailure 1
66+
test/Reflex/Test/CrossImpl.hsnew file+258
@@ -0,0 +1,258 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecursiveDo #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+module Reflex.Test.CrossImpl (test) where
16+
17+import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)
18+
19+import Control.Monad.Ref
20+import Reflex.Class
21+import Reflex.Dynamic
22+import Reflex.Host.Class
23+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
24+import qualified Reflex.Pure as P
25+import qualified Reflex.Spider.Internal as S
26+
27+import Control.Arrow (second, (&&&))
28+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
30+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
31+import Data.Dependent.Map (DMap, DSum (..))
32+import qualified Data.Dependent.Map as DMap
33+import Data.Foldable
34+import Data.Functor.Misc
35+import Data.Map.Strict (Map)
36+import qualified Data.Map.Strict as Map
37+import qualified Data.Set as Set
38+import Data.Traversable
39+import System.Exit
40+import System.Mem
41+
42+import System.IO.Unsafe
43+
44+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
45+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
46+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
47+ Just (_, v) -> v
48+
49+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
50+mapToPureEvent m = P.Event $ flip Map.lookup m
51+
52+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
53+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
54+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
55+ _ -> [] -- Doesn't actually make much sense
56+
57+type PureReflexDomain = P.Pure Int
58+type TimeM = (->) Int
59+
60+testPure :: (t ~ PureReflexDomain, m ~ TimeM) => ((Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
61+testPure builder (b, e) =
62+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
63+ relevantTimes = relevantTestingTimes (b, e)
64+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
65+ b'' = Map.fromList $ map (id &&& b') relevantTimes
66+ in (b'', e'')
67+
68+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
69+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
70+
71+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
72+ mapMSignals fb _ = fb
73+
74+instance MapMSignals (Event t a) (Event t' a) t t' where
75+ mapMSignals _ fe = fe
76+
77+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
78+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
79+
80+testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
81+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
82+ (re, reTrigger) <- newEventWithTriggerRef
83+ (rb, rbTrigger) <- newEventWithTriggerRef
84+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
85+ (b', e') <- runHostFrame $ builder (b, re)
86+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
87+ let times = relevantTestingTimes (bMap, eMap)
88+ liftIO performGC
89+ outputs <- forM times $ \t -> do
90+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
91+ bOutput <- sample b'
92+ eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do
93+ mret <- readRef reTrigger
94+ let firing = case mret of
95+ Just ret -> [ret :=> Identity val]
96+ Nothing -> []
97+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
98+ liftIO performGC
99+ return (t, (bOutput, eOutput))
100+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
101+
102+tracePerf :: Show a => a -> b -> b
103+tracePerf = flip const
104+
105+testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> IO Bool
106+testAgreement builder inputs = do
107+ let identityResult = testPure builder inputs
108+ tracePerf "---------" $ return ()
109+ let spiderResult = testSpider builder inputs
110+ tracePerf "---------" $ return ()
111+ let resultsAgree = identityResult == spiderResult
112+ if resultsAgree
113+ then do --putStrLn "Success:"
114+ --print identityResult
115+ return ()
116+ else do putStrLn "Failure:"
117+ putStrLn $ "Pure result: " <> show identityResult
118+ putStrLn $ "Spider result: " <> show spiderResult
119+ return resultsAgree
120+
121+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
122+
123+data TestCase = forall a b c d. (Eq c, Eq d, Show c, Show d) => TestCase (Map Int a, Map Int b) (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
124+
125+testCases :: [(String, TestCase)]
126+testCases =
127+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
128+ b' <- hold "123" e
129+ return (b', e)
130+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
131+ e' <- updated <$> count e
132+ b' <- hold (0 :: Int) e'
133+ return (b', e')
134+ , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
135+ e' <- headE $ leftmost [e, e]
136+ return (b, e')
137+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
138+ let e' = fmap (const e) e
139+ b' <- hold never e'
140+ let e'' = switch b'
141+ return (b, e'')
142+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
143+ let e' = flip pushAlways e $ const $ do
144+ let eab = splitRecombineEvent e
145+ switch <$> hold eab never
146+ e'' = coincidence e'
147+ return (b, e'')
148+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
149+ let e' = flip pushAlways e $ const $ do
150+ let eab = splitRecombineEvent e
151+ switch <$> hold eab (fmap (const e) e)
152+ e'' = coincidence e'
153+ return (b, e'')
154+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
155+ let e' = leftmost [e, e]
156+ e'' <- switch <$> hold e' (fmap (const e) e)
157+ return (b, e'')
158+ , (,) "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