git.iko.soy/patch
on 2f13f08 help sign in
b6af869
swap
0 ahead, 976 behind
.ghci+2
since splitsnapshots
unifiedsplit
@@ -1,2 +1,4 @@
1:set -isrc
1:set -isrc
2+:set -hide-package MonadCatchIO-mtl
3+:set -hide-package monads-fd
2:seti -XOverloadedStrings
4:seti -XOverloadedStrings
.github/workflows/haskell.ymldeleted−47
@@ -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
.gitignore−7
@@ -1,7 +1,4 @@
1dist
1dist
2−cabal.sandbox.config
3−.cabal-sandbox/
4−dist-*
5cabal-dev
2cabal-dev
6*.o
3*.o
7*.hi
4*.hi
@@ -32,7 +29,3 @@ tags
32hsenv.log
29hsenv.log
33\#*#
30\#*#
34.#*
31.#*
35−/shell.nix
36−/ghci-tmp
37−*.dump-*
38−*.verbose-core2core
.stylish-haskell.yamldeleted−153
@@ -1,153 +0,0 @@
1−# stylish-haskell configuration file
2−# ==================================
3−
4−# The stylish-haskell tool is mainly configured by specifying steps. These steps
5−# are a list, so they have an order, and one specific step may appear more than
6−# once (if needed). Each file is processed by these steps in the given order.
7−steps:
8− # Convert some ASCII sequences to their Unicode equivalents. This is disabled
9− # by default.
10− # - unicode_syntax:
11− # # In order to make this work, we also need to insert the UnicodeSyntax
12− # # language pragma. If this flag is set to true, we insert it when it's
13− # # not already present. You may want to disable it if you configure
14− # # language extensions using some other method than pragmas. Default:
15− # # true.
16− # add_language_pragma: true
17−
18− # Import cleanup
19− - imports:
20− # There are different ways we can align names and lists.
21− #
22− # - global: Align the import names and import list throughout the entire
23− # file.
24− #
25− # - file: Like global, but don't add padding when there are no qualified
26− # imports in the file.
27− #
28− # - group: Only align the imports per group (a group is formed by adjacent
29− # import lines).
30− #
31− # - none: Do not perform any alignment.
32− #
33− # Default: global.
34− align: none
35−
36− # Folowing options affect only import list alignment.
37− #
38− # List align has following options:
39− #
40− # - after_alias: Import list is aligned with end of import including
41− # 'as' and 'hiding' keywords.
42− #
43− # > import qualified Data.List as List (concat, foldl, foldr, head,
44− # > init, last, length)
45− #
46− # - with_alias: Import list is aligned with start of alias or hiding.
47− #
48− # > import qualified Data.List as List (concat, foldl, foldr, head,
49− # > init, last, length)
50− #
51− # - new_line: Import list starts always on new line.
52− #
53− # > import qualified Data.List as List
54− # > (concat, foldl, foldr, head, init, last, length)
55− #
56− # Default: after alias
57− list_align: after_alias
58−
59− # Long list align style takes effect when import is too long. This is
60− # determined by 'columns' setting.
61− #
62− # - inline: This option will put as much specs on same line as possible.
63− #
64− # - new_line: Import list will start on new line.
65− #
66− # - new_line_multiline: Import list will start on new line when it's
67− # short enough to fit to single line. Otherwise it'll be multiline.
68− #
69− # - multiline: One line per import list entry.
70− # Type with contructor list acts like single import.
71− #
72− # > import qualified Data.Map as M
73− # > ( empty
74− # > , singleton
75− # > , ...
76− # > , delete
77− # > )
78− #
79− # Default: inline
80− long_list_align: inline
81−
82− # List padding determines indentation of import list on lines after import.
83− # This option affects 'list_align' and 'long_list_align'.
84− list_padding: 2
85−
86− # Separate lists option affects formating of import list for type
87− # or class. The only difference is single space between type and list
88− # of constructors, selectors and class functions.
89− #
90− # - true: There is single space between Foldable type and list of it's
91− # functions.
92− #
93− # > import Data.Foldable (Foldable (fold, foldl, foldMap))
94− #
95− # - false: There is no space between Foldable type and list of it's
96− # functions.
97− #
98− # > import Data.Foldable (Foldable(fold, foldl, foldMap))
99− #
100− # Default: true
101− separate_lists: true
102−
103− # Language pragmas
104− - language_pragmas:
105− # We can generate different styles of language pragma lists.
106− #
107− # - vertical: Vertical-spaced language pragmas, one per line.
108− #
109− # - compact: A more compact style.
110− #
111− # - compact_line: Similar to compact, but wrap each line with
112− # `{-#LANGUAGE #-}'.
113− #
114− # Default: vertical.
115− style: vertical
116−
117− # Align affects alignment of closing pragma brackets.
118− #
119− # - true: Brackets are aligned in same collumn.
120− #
121− # - false: Brackets are not aligned together. There is only one space
122− # between actual import and closing bracket.
123− #
124− # Default: true
125− align: false
126−
127− # stylish-haskell can detect redundancy of some language pragmas. If this
128− # is set to true, it will remove those redundant pragmas. Default: true.
129− remove_redundant: true
130−
131− # Align the types in record declarations
132− # - records: {}
133−
134− # Replace tabs by spaces. This is disabled by default.
135− # - tabs:
136− # # Number of spaces to use for each tab. Default: 8, as specified by the
137− # # Haskell report.
138− # spaces: 8
139−
140− # Remove trailing whitespace
141− - trailing_whitespace: {}
142−
143−# A common setting is the number of columns (parts of) code will be wrapped
144−# to. Different steps take this into account. Default: 80.
145−columns: 110
146−
147−# Sometimes, language extensions are specified in a cabal file or from the
148−# command line instead of using language pragmas in the file. stylish-haskell
149−# needs to be aware of these, so it can parse the file correctly.
150−#
151−# No language extensions are enabled by default.
152−language_extensions:
153− - TemplateHaskell
.travis.ymlnew file+24
@@ -0,0 +1,24 @@
1+sudo: false
2+before_install:
3+ - travis_retry cabal-$CABALVER update
4+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/happy/1.19.5/bin:/opt/alex/3.1.4/bin:$PATH
5+install:
6+ - travis_retry cabal-$CABALVER install --only-dependencies -j --enable-tests
7+script:
8+ - cabal-$CABALVER configure -v2 --enable-tests
9+ - cabal-$CABALVER build
10+ - cabal-$CABALVER test
11+ - cabal-$CABALVER sdist # tests that a source-distribution can be generated
12+# Check that the resulting source distribution can be built & installed.
13+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
14+# `cabal install --force-reinstalls dist/*-*.tar.gz`
15+ - SRC_TGZ=$(cabal-$CABALVER info . | awk '{print $2;exit}').tar.gz &&
16+ (cd dist && cabal-$CABALVER install --force-reinstalls "$SRC_TGZ")
17+
18+matrix:
19+ include:
20+ - env: CABALVER=1.18 GHCVER=7.8.4
21+ addons: {apt: {packages: [cabal-install-1.18, ghc-7.8.4, alex-3.1.4, happy-1.19.5], sources: [hvr-ghc]}}
22+ - env: CABALVER=1.22 GHCVER=7.10.1
23+ addons: {apt: {packages: [cabal-install-1.22, ghc-7.10.1, alex-3.1.4, happy-1.19.5],sources: [hvr-ghc]}}
24+ fast_finish: true
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+171
@@ -0,0 +1,171 @@
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+[ ] tagDyn :: Dynamic a -> Event b -> Event a
43+[ ] attach :: Behavior a -> Event b -> Event (a, b)
44+[ ] attachDyn :: Dynamic a -> Event b -> Event (a, b)
45+[ ] attachWith :: (a -> b -> c) -> Behavior a -> Event b -> Event c
46+[ ] attachDynWith :: (a -> b -> c) -> Dynamic a -> Event b -> Event c
47+[ ] attachWithMaybe :: (a -> b -> Maybe c) -> Behavior a -> Event b -> Event c
48+[ ] attachDynWithMaybe :: (a -> b -> Maybe c) -> Dynamic a -> Event b -> Event c
49+
50+-- Combine multiple Events
51+[ ] <> :: Monoid a => Event a -> Event a -> Event a
52+[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
53+[ ] leftmost :: [Event a] -> Event a
54+[ ] mergeList :: [Event a] -> Event (NonEmpty a)
55+[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)
56+[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)
57+
58+-- Efficient one-to-many fanout
59+[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)
60+[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k
61+[ ] select :: EventSelector k -> k a -> Event a
62+
63+-- Event to Event via function that can sample current values
64+[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b
65+[ ] pushAlways :: (a -> m b ) -> Event a -> Event b
66+ -- Note supplied function operates in [H] context
67+
68+-- Split Event into next occurrence and all other future occurrences, as of now.
69+[H] headE :: Event a -> m (Event a)
70+[H] tailE :: Event a -> m (Event a)
71+[H] headTailE :: Event a -> m (Event a, Event a)
72+```
73+
74+## Functions producing Behavior
75+
76+```haskell
77+-- Trivial Behavior
78+[ ] constant :: a -> Behavior a
79+
80+-- Extract Behavior from Dynamic
81+[ ] current :: Dynamic a -> Behavior a
82+
83+-- Create Behavior with given initial value, updated when the Event fires.
84+[H] hold :: a -> Event a -> m (Behavior a)
85+
86+-- Transform Behavior to Behavior using function
87+[ ] fmap :: (a -> b) -> Behavior a -> Behavior b
88+[ ] ffor :: Behavior a -> (a -> b) -> Behavior b
89+[ ] <*> :: Behavior (a -> b) -> Behavior a -> Behavior b
90+[ ] >>= :: Behavior a -> (a -> Behavior b) -> Behavior b
91+[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a
92+-- ... plus many more due to typeclass membership
93+
94+-- Behavior to Behavior by sampling current values
95+[S] sample :: Behavior a -> m a
96+[ ] pull :: m a -> Behavior a
97+ -- Note supplied value is in [S] context
98+```
99+
100+## Functions producing Dynamic
101+
102+```haskell
103+-- Trivial Dynamic
104+[ ] constDyn :: a -> Dynamic a
105+
106+-- Create Dynamic with given initial value, updated (various ways) when the Event fires.
107+[H] holdDyn :: a -> Event a -> m (Dynamic a)
108+[H] foldDyn :: (a -> b -> b ) -> b -> Event a -> m (Dynamic b)
109+[H] foldDynMaybe :: (a -> b -> Maybe b ) -> b -> Event a -> m (Dynamic b)
110+[H] foldDynM :: (a -> b -> m' b ) -> b -> Event a -> m (Dynamic b)
111+[H] foldDynMaybeM :: (a -> b -> m' (Maybe b)) -> b -> Event a -> m (Dynamic b)
112+ -- Note m' supplies [H] context
113+
114+-- Initial value is 0; counts Event firings from now.
115+[H] count :: Num b => Event a -> m (Dynamic b)
116+-- Initial Bool value is supplied; toggles at each Event firing.
117+[H] toggle :: Bool -> Event a -> m (Dynamic Bool)
118+
119+-- Transform Dynamic to Dynamic using function
120+[H] forDyn :: Dynamic a -> (a -> b) -> m (Dynamic b)
121+[H] mapDyn :: (a -> b) -> Dynamic a -> m (Dynamic b)
122+[H] mapDynM :: (a -> m' b) -> Dynamic a -> m (Dynamic b)
123+ -- Note m' supplies [S] context
124+[H] splitDyn :: Dynamic (a, b) -> m (Dynamic a, Dynamic b)
125+
126+-- Combine multiple Dynamics
127+[H] mconcatDyn :: Monoid a => [Dynamic a] -> m (Dynamic a)
128+[H] distributeDMapOverDyn :: GCompare k => DMap (WrapArg Dynamic k) -> m (Dynamic (DMap k))
129+[H] combineDyn :: (a -> b -> c) -> Dynamic a -> Dynamic b -> m (Dynamic c)
130+
131+-- Efficient one-to-many fanout
132+[ ] demux :: Ord k => Dynamic k -> Demux k
133+[H] getDemuxed :: Eq k => Demux k -> k -> m (Dynamic Bool)
134+
135+-- Dynamic to Dynamic, removing updates w/o value change
136+[ ] nubDyn :: Eq a => Dynamic a -> Dynamic a
137+
138+-- Dynamic to identical Dynamic with debug trace. (Only prints if Dynamic is ultimately used.)
139+[ ] traceDyn :: Show a => String -> Dynamic a -> Dynamic a
140+[ ] traceDynWith :: (a -> String) -> Dynamic a -> Dynamic a
141+```
142+
143+## Flattening functions
144+
145+These functions flatten nested types such as Event-of-Event, Behavior-of-Event, Event-of-Behavior etc, removing the outer wrapper.
146+
147+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.
148+
149+```haskell
150+-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.
151+[ ] switch :: Behavior (Event a) -> Event a
152+
153+-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.
154+[ ] switchPromptlyDyn :: Dynamic (Event a) -> Event a
155+
156+-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.
157+[ ] coincidence :: Event (Event a) -> Event a
158+
159+-- Flatten Dynamic-of-Dynamic to Dynamic. New Dynamic is used immediately.
160+-- Output updated whenever inner OR outer Dynamic updates.
161+[ ] joinDyn :: Dynamic (Dynamic a) -> Dynamic a
162+[ ] joinDynThroughMap :: Ord k => Dynamic (Map k (Dynamic a)) -> Dynamic (Map k a)
163+
164+-- Analogous to 'hold': Create a Behavior that is initially identical to the
165+-- supplied Behavior. Updated to track a new Behavior whenever the Event fires.
166+[H] switcher :: Behavior a -> Event (Behavior a) -> m (Behavior a)
167+
168+-- Similar to above, for Events. Created Event initially tracks the first argument.
169+-- At switchover, the output Event immediately tracks the new Event.
170+[H] switchPromptly :: Event a -> Event (Event a) -> m (Event a)
171+```
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/ryantrinkle/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/ryantrinkle/try-reflex 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+[try reflex](https://github.com/ryantrinkle/try-reflex)
19
14
20−`PatchMap` is defined as:
15+[reddit/r/reflexfrp](http://www.reddit.com/r/reflexfrp)
21
16
22−```haskell
17+[reflex at 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
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.cdeleted−208
@@ -1,208 +0,0 @@
1−#include <Rts.h>
2−
3−// The InCall structure represents either a single in-call from C to
4−// Haskell, or a worker thread.
5−typedef struct InCall_ {
6− StgTSO * tso; // the bound TSO (or NULL for a worker)
7−
8− StgTSO * suspended_tso; // the TSO is stashed here when we
9− // make a foreign call (NULL otherwise);
10−
11− Capability *suspended_cap; // The capability that the
12− // suspended_tso is on, because
13− // we can't read this from the TSO
14− // without owning a Capability in the
15− // first place.
16−
17− SchedulerStatus rstat; // return status
18− StgClosure ** ret; // return value
19−
20− struct Task_ *task;
21−
22− // When a Haskell thread makes a foreign call that re-enters
23− // Haskell, we end up with another Task associated with the
24− // current thread. We have to remember the whole stack of InCalls
25− // associated with the current Task so that we can correctly
26− // save & restore the InCall on entry to and exit from Haskell.
27− struct InCall_ *prev_stack;
28−
29− // Links InCalls onto suspended_ccalls, spare_incalls
30− struct InCall_ *prev;
31− struct InCall_ *next;
32−} InCall;
33−
34−typedef struct Task_ {
35−#if defined(THREADED_RTS)
36− OSThreadId id; // The OS Thread ID of this task
37−
38− Condition cond; // used for sleeping & waking up this task
39− Mutex lock; // lock for the condition variable
40−
41− // this flag tells the task whether it should wait on task->cond
42− // or just continue immediately. It's a workaround for the fact
43− // that signalling a condition variable doesn't do anything if the
44− // thread is already running, but we want it to be sticky.
45− HsBool wakeup;
46−#endif
47−
48− // This points to the Capability that the Task "belongs" to. If
49− // the Task owns a Capability, then task->cap points to it. If
50− // the task does not own a Capability, then either (a) if the task
51− // is a worker, then task->cap points to the Capability it belongs
52− // to, or (b) it is returning from a foreign call, then task->cap
53− // points to the Capability with the returning_worker queue that this
54− // this Task is on.
55− //
56− // When a task goes to sleep, it may be migrated to a different
57− // Capability. Hence, we always check task->cap on wakeup. To
58− // syncrhonise between the migrater and the migratee, task->lock
59− // must be held when modifying task->cap.
60− struct Capability_ *cap;
61−
62− // The current top-of-stack InCall
63− struct InCall_ *incall;
64−
65− uint32_t n_spare_incalls;
66− struct InCall_ *spare_incalls;
67−
68− HsBool worker; // == rtsTrue if this is a worker Task
69− HsBool stopped; // this task has stopped or exited Haskell
70−
71− // So that we can detect when a finalizer illegally calls back into Haskell
72− HsBool running_finalizers;
73−
74− // Links tasks on the returning_tasks queue of a Capability, and
75− // on spare_workers.
76− struct Task_ *next;
77−
78− // Links tasks on the all_tasks list; need ACQUIRE_LOCK(&all_tasks_mutex)
79− struct Task_ *all_next;
80− struct Task_ *all_prev;
81−
82−} Task;
83−
84−struct Capability_ {
85− // State required by the STG virtual machine when running Haskell
86− // code. During STG execution, the BaseReg register always points
87− // to the StgRegTable of the current Capability (&cap->r).
88− StgFunTable f;
89− StgRegTable r;
90−
91− uint32_t no; // capability number.
92−
93− // The Task currently holding this Capability. This task has
94− // exclusive access to the contents of this Capability (apart from
95− // returning_tasks_hd/returning_tasks_tl).
96− // Locks required: cap->lock.
97− Task *running_task;
98−
99− // true if this Capability is running Haskell code, used for
100− // catching unsafe call-ins.
101− HsBool in_haskell;
102−
103− // Has there been any activity on this Capability since the last GC?
104− uint32_t idle;
105−
106− HsBool disabled;
107−
108− // The run queue. The Task owning this Capability has exclusive
109− // access to its run queue, so can wake up threads without
110− // taking a lock, and the common path through the scheduler is
111− // also lock-free.
112− StgTSO *run_queue_hd;
113− StgTSO *run_queue_tl;
114−
115− // Tasks currently making safe foreign calls. Doubly-linked.
116− // When returning, a task first acquires the Capability before
117− // removing itself from this list, so that the GC can find all
118− // the suspended TSOs easily. Hence, when migrating a Task from
119− // the returning_tasks list, we must also migrate its entry from
120− // this list.
121− InCall *suspended_ccalls;
122−
123− // One mutable list per generation, so we don't need to take any
124− // locks when updating an old-generation thunk. This also lets us
125− // keep track of which closures this CPU has been mutating, so we
126− // can traverse them using the right thread during GC and avoid
127− // unnecessarily moving the data from one cache to another.
128− bdescr **mut_lists;
129− bdescr **saved_mut_lists; // tmp use during GC
130−
131− // block for allocating pinned objects into
132− bdescr *pinned_object_block;
133− // full pinned object blocks allocated since the last GC
134− bdescr *pinned_object_blocks;
135−
136− // per-capability weak pointer list associated with nursery (older
137− // lists stored in generation object)
138− StgWeak *weak_ptr_list_hd;
139− StgWeak *weak_ptr_list_tl;
140−
141− // Context switch flag. When non-zero, this means: stop running
142− // Haskell code, and switch threads.
143− int context_switch;
144−
145− // Interrupt flag. Like the context_switch flag, this also
146− // indicates that we should stop running Haskell code, but we do
147− // *not* switch threads. This is used to stop a Capability in
148− // order to do GC, for example.
149− //
150− // The interrupt flag is always reset before we start running
151− // Haskell code, unlike the context_switch flag which is only
152− // reset after we have executed the context switch.
153− int interrupt;
154−
155− // Total words allocated by this cap since rts start
156− // See [Note allocation accounting] in Storage.c
157− W_ total_allocated;
158−
159−#if defined(THREADED_RTS)
160− // Worker Tasks waiting in the wings. Singly-linked.
161− Task *spare_workers;
162− uint32_t n_spare_workers; // count of above
163−
164− // This lock protects:
165− // running_task
166− // returning_tasks_{hd,tl}
167− // wakeup_queue
168− // inbox
169− Mutex lock;
170−
171− // Tasks waiting to return from a foreign call, or waiting to make
172− // a new call-in using this Capability (NULL if empty).
173− // NB. this field needs to be modified by tasks other than the
174− // running_task, so it requires cap->lock to modify. A task can
175− // check whether it is NULL without taking the lock, however.
176− Task *returning_tasks_hd; // Singly-linked, with head/tail
177− Task *returning_tasks_tl;
178−
179− // Messages, or END_TSO_QUEUE.
180− // Locks required: cap->lock
181− Message *inbox;
182−
183− SparkPool *sparks;
184−
185− // Stats on spark creation/conversion
186− SparkCounters spark_stats;
187−#if !defined(mingw32_HOST_OS)
188− // IO manager for this cap
189− int io_manager_control_wr_fd;
190−#endif
191−#endif
192−
193− // Per-capability STM-related data
194− StgTVarWatchQueue *free_tvar_watch_queues;
195− StgTRecChunk *free_trec_chunks;
196− StgTRecHeader *free_trec_headers;
197− uint32_t transaction_tokens;
198−} // typedef Capability is defined in RtsAPI.h
199− // We never want a Capability to overlap a cache line with anything
200− // else, so round it up to a cache line size:
201−#ifndef mingw32_HOST_OS
202− ATTRIBUTE_ALIGNED(64)
203−#endif
204− ;
205−
206−HsBool myCapabilityHasOtherRunnableThreads() {
207− return rts_unsafeGetMyCapability()->run_queue_hd == END_TSO_QUEUE ? HS_BOOL_FALSE : HS_BOOL_TRUE;
208−}
bench/Main.hsnew file+111
@@ -0,0 +1,111 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TypeFamilies #-}
5+module Main where
6+
7+import Data.Functor.Misc
8+import Control.Monad.Primitive
9+import Control.Monad.IO.Class
10+import Control.Monad.Identity
11+import Data.Dependent.Sum
12+import Control.Concurrent.STM
13+import Control.Applicative
14+import System.IO.Unsafe
15+import Data.IORef
16+import Control.DeepSeq
17+import Control.Exception (evaluate)
18+import Control.Monad
19+import Reflex
20+import Reflex.Host.Class
21+import System.Mem
22+import System.IO
23+import Criterion.Main
24+
25+import qualified Data.Traversable as T
26+
27+import qualified Data.Dependent.Map as DM
28+
29+
30+main :: IO ()
31+main = defaultMain
32+ [ bgroup "micro" micros ]
33+
34+instance NFData (IORef a) where
35+ rnf x = seq x ()
36+
37+instance NFData (TVar a) where
38+ rnf x = seq x ()
39+
40+newtype WHNF a = WHNF a
41+instance NFData (WHNF a) where
42+ rnf (WHNF a) = seq a ()
43+
44+withSetup :: NFData b => String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
45+withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
46+ bench name . nfIO $ runSpiderHost (action a)
47+
48+withSetupWHNF :: String -> SpiderHost a -> (a -> SpiderHost b) -> Benchmark
49+withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
50+ bench name . whnfIO $ runSpiderHost (action a)
51+
52+
53+micros :: [Benchmark]
54+micros =
55+ [ bench "newIORef" $ whnfIO $ void $ newIORef ()
56+ , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef)
57+ , bench "newTVar" $ whnfIO $ void $ newTVarIO ()
58+ , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO)
59+ , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $
60+ \trigger -> return () <$ evaluate trigger
61+ , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef
62+ , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst
63+ , withSetupWHNF "subscribeSwitch"
64+ (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef)
65+ (subscribeEvent . switch)
66+ , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev
67+ , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst)
68+ , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst)
69+ , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return ()
70+ , withSetupWHNF "fireEventsAndRead(single/single)"
71+ (newEventWithTriggerRef >>= subscribePair)
72+ (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
73+ , withSetupWHNF "fireEventsOnly"
74+ (newEventWithTriggerRef >>= subscribePair)
75+ (\(subd, trigger) -> do
76+ Just key <- liftIO $ readIORef trigger
77+ fireEvents [key :=> Identity (42 :: Int)])
78+ , withSetupWHNF "fireEventsAndRead(head/merge1)"
79+ (setupMerge 1 >>= subscribePair)
80+ (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
81+ , withSetupWHNF "fireEventsAndRead(head/merge100)"
82+ (setupMerge 100 >>= subscribePair)
83+ (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
84+ , withSetupWHNF "fireEventsAndRead(head/merge10000)"
85+ (setupMerge 10000 >>= subscribePair)
86+ (\(subd, t:riggers) -> fireAndRead t (42 :: Int) subd)
87+ , withSetupWHNF "fireEventsOnly(head/merge100)"
88+ (setupMerge 100 >>= subscribePair)
89+ (\(subd, t:riggers) -> do
90+ Just key <- liftIO $ readIORef t
91+ fireEvents [key :=> Identity (42 :: Int)])
92+ , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev,trigger) -> hold (42 :: Int) ev
93+ , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
94+ ]
95+
96+setupMerge :: Int
97+ -> SpiderHost (Event Spider (DM.DMap (Const2 Int a) Identity),
98+ [IORef (Maybe (EventTrigger Spider a))])
99+setupMerge num = do
100+ (evs, triggers) <- unzip <$> replicateM 100 newEventWithTriggerRef
101+ let !m = DM.fromList [(Const2 i) :=> v | (i,v) <- zip [0..] evs]
102+ pure (merge m, triggers)
103+
104+subscribePair :: (Event Spider a, b) -> SpiderHost (EventHandle Spider a, b)
105+subscribePair (ev, b) = (,b) <$> subscribeEvent ev
106+
107+fireAndRead :: IORef (Maybe (EventTrigger Spider a)) -> a -> EventHandle Spider b
108+ -> SpiderHost (Maybe b)
109+fireAndRead trigger val subd = do
110+ Just key <- liftIO $ readIORef trigger
111+ fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= T.sequence
bench/RunAll.hsnew file+86
@@ -0,0 +1,86 @@
1+{-# LANGUAGE ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+module Main where
5+
6+import Criterion.Main
7+import Criterion.Types
8+
9+import Reflex
10+import Reflex.Host.Class
11+
12+import Reflex.TestPlan
13+import Reflex.Plan.Reflex
14+
15+import Reflex.Spider.Internal (SpiderEventHandle)
16+import qualified Reflex.Bench.Focused as Focused
17+
18+import Control.Applicative
19+import Control.DeepSeq (NFData (..))
20+
21+import System.IO
22+import System.Mem
23+import Prelude
24+
25+type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))
26+
27+
28+setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (Ignore (EventHandle t a), Schedule t)
29+setupFiring p = do
30+ (e, s) <- runPlan p
31+ h <- subscribeEvent e
32+ return (Ignore h, s)
33+
34+-- Hack to avoid the NFData constraint for EventHandle which is a synonym
35+newtype Ignore a = Ignore a
36+instance NFData (Ignore a) where
37+ rnf !_ = ()
38+
39+instance NFData (SpiderEventHandle a) where
40+ rnf !_ = ()
41+
42+instance NFData (Behavior t a) where
43+ rnf !_ = ()
44+
45+instance NFData (Firing t) where
46+ rnf !(Firing _ _) = ()
47+
48+-- Measure the running time
49+benchFiring :: (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> (String, TestCase) -> Benchmark
50+benchFiring runHost (name, TestE p) = env setup (\e -> bench name $ whnfIO $ run e) where
51+ run (Ignore h, s) = runHost (readSchedule s (readEvent' h)) >> performGC
52+ setup = runHost $ setupFiring p
53+
54+benchFiring runHost (name, TestB p) = env setup (\e -> bench name $ whnfIO $ run e) where
55+ run (b, s) = runHost (readSchedule s (sample b)) >> performGC
56+ setup = runHost $ do
57+ (b, s) <- runPlan p
58+ return (b, makeDense s)
59+
60+main :: IO ()
61+main = do
62+ hSetBuffering stdout LineBuffering
63+ defaultMainWith (defaultConfig { timeLimit = 10, csvFile = Just "dmap-original.csv" })
64+ [ benchImpl "spider" runSpiderHost
65+ ]
66+
67+benchImpl :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> Benchmark
68+benchImpl name runHost = bgroup name [ sub 100 40
69+ , dynamics 100
70+ , dynamics 1000
71+ , firing 1000
72+ , firing 10000
73+ , merging 10
74+ , merging 50
75+ , merging 100
76+ , merging 200]
77+ where
78+ sub n frames = runGroup ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames
79+ firing n = runGroup ("firing " ++ show n) $ Focused.firing n
80+ merging n = runGroup ("merging " ++ show n) $ Focused.merging n
81+ dynamics n = runGroup ("dynamics " ++ show n) $ Focused.dynamics n
82+
83+ runGroup name' benchmarks = bgroup name' (benchFiring runHost <$> benchmarks)
84+
85+
86+
cabal.projectdeleted−1
@@ -1 +0,0 @@
1−packages: .
default.nixnew file+17
@@ -0,0 +1,17 @@
1+{ mkDerivation, dependent-map, dependent-sum
2+, mtl, ref-tf, semigroups, these, MemoTrie, exception-transformers
3+, haskell-src-exts, haskell-src-meta
4+}:
5+mkDerivation {
6+ pname = "reflex";
7+ version = "0.4.0";
8+ src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
9+ buildDepends = [
10+ dependent-map dependent-sum mtl ref-tf semigroups these exception-transformers
11+ haskell-src-exts haskell-src-meta
12+ ];
13+ testDepends = [
14+ MemoTrie
15+ ];
16+ license = null;
17+}
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+108
@@ -0,0 +1,108 @@
1+Name: reflex
2+Version: 0.4.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/ryantrinkle/reflex
14+bug-reports: https://github.com/ryantrinkle/reflex/issues
15+
16+library
17+ hs-source-dirs: src
18+ build-depends:
19+ base >= 4.7 && < 4.9,
20+ dependent-sum == 0.3.*,
21+ dependent-map == 0.2.*,
22+ semigroups >= 0.16 && < 0.19,
23+ mtl >= 2.1 && < 2.3,
24+ containers == 0.5.*,
25+ these >= 0.4 && < 0.7,
26+ primitive >= 0.5 && < 0.7,
27+ template-haskell >= 2.9 && < 2.11,
28+ ref-tf == 0.4.*,
29+ exception-transformers == 0.4.*,
30+ transformers >= 0.2,
31+ transformers-compat >= 0.3,
32+ haskell-src-exts >= 1.16 && < 1.18,
33+ haskell-src-meta == 0.6.*,
34+ syb >= 0.5 && < 0.7
35+
36+ exposed-modules:
37+ Reflex,
38+ Reflex.Spider,
39+ Reflex.Spider.Internal,
40+ Reflex.Class,
41+ Reflex.Dynamic,
42+ Reflex.Dynamic.TH,
43+ Reflex.Host.Class,
44+ Data.Functor.Misc
45+
46+ other-extensions: TemplateHaskell
47+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
48+
49+
50+test-suite all
51+ type: exitcode-stdio-1.0
52+ main-is: Reflex/Test/RunAll.hs
53+ ghc-options: -O2 -Wall
54+ hs-source-dirs: test
55+ build-depends:
56+ base,
57+ reflex,
58+ ref-tf,
59+ mtl,
60+ containers,
61+ dependent-map,
62+ dependent-sum,
63+ transformers >= 0.3 && < 0.5,
64+ MemoTrie == 0.6.*,
65+ bifunctors,
66+ split
67+
68+
69+benchmark spider-bench
70+ type: exitcode-stdio-1.0
71+ hs-source-dirs: bench
72+ main-is: Main.hs
73+ ghc-options: -O2 -rtsopts
74+ build-depends:
75+ base,
76+ dependent-sum,
77+ dependent-map,
78+ transformers >= 0.3 && < 0.5,
79+ stm == 2.4.*,
80+ deepseq >= 1.3 && < 1.5,
81+ mtl,
82+ primitive,
83+ criterion == 1.1.*,
84+ reflex
85+
86+benchmark saulzar-bench
87+ type: exitcode-stdio-1.0
88+ hs-source-dirs: bench test
89+ main-is: RunAll.hs
90+ ghc-options: -O2 -rtsopts
91+ build-depends:
92+ base,
93+ containers == 0.5.*,
94+ ref-tf == 0.4,
95+ dependent-sum,
96+ dependent-map,
97+ transformers >= 0.3 && < 0.5,
98+ stm == 2.4.*,
99+ deepseq >= 1.3 && < 1.5,
100+ mtl,
101+ primitive,
102+ criterion == 1.1.*,
103+ split,
104+ reflex
105+
106+source-repository head
107+ type: git
108+ location: https://github.com/ryantrinkle/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/Functor/Misc.hs+43−198
@@ -1,78 +1,30 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, PolyKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE StandaloneDeriving #-}
13−-- | This module provides types and functions with no particular theme, but
14−-- which are relevant to the use of 'Functor'-based datastructures like
15−-- 'Data.Dependent.Map.DMap'.
16−module Data.Functor.Misc
2+module Data.Functor.Misc where
17− ( -- * Const2
3+
18− Const2 (..)
19− , unConst2
20− , dmapToMap
21− , dmapToIntMap
22− , dmapToMapWith
23− , mapToDMap
24− , weakenDMapWith
25− -- * WrapArg
26− , WrapArg (..)
27− -- * Convenience functions for DMap
28− , mapWithFunctorToDMap
29− , intMapWithFunctorToDMap
30− , mapKeyValuePairsMonotonic
31− , combineDMapsWithKey
32− , EitherTag (..)
33− , dmapToThese
34− , eitherToDSum
35− , dsumToEither
36− , ComposeMaybe (..)
37− ) where
38−
39−import Control.Applicative ((<$>))
40−import Data.Dependent.Map (DMap)
41−import qualified Data.Dependent.Map as DMap
42−import Data.Dependent.Sum
43−import Data.Functor.Identity
44import Data.GADT.Compare
4import Data.GADT.Compare
45−import Data.GADT.Show
46−import Data.IntMap (IntMap)
47−import qualified Data.IntMap as IntMap
48import Data.Map (Map)
5import Data.Map (Map)
49import qualified Data.Map as Map
6import qualified Data.Map as Map
50−import Data.Some (Some, mkSome)
7+import Data.Dependent.Map (DMap, DSum (..))
51−import Data.These
8+import qualified Data.Dependent.Map as DMap
52−import Data.Type.Equality ((:~:)(Refl))
53import Data.Typeable hiding (Refl)
9import Data.Typeable hiding (Refl)
10+import Data.These
11+import Control.Monad.Identity
54
12
55−--------------------------------------------------------------------------------
56−-- Const2
57−--------------------------------------------------------------------------------
58−
59−-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
60−-- type 'v' is always given for the last type parameter
61−data Const2 :: * -> x -> x -> * where
13+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
62− Const2 :: k -> Const2 k v v
14+ WrapArg :: f a -> WrapArg g f (g a)
63− deriving (Typeable)
64
15
65−-- | Extract the value from a Const2
16+instance GEq f => GEq (WrapArg g f) where
66−unConst2 :: Const2 k v v' -> k
17+ geq (WrapArg a) (WrapArg b) = fmap (\Refl -> Refl) $ geq a b
67−unConst2 (Const2 k) = k
68
18
69−deriving instance Eq k => Eq (Const2 k v v')
19+instance GCompare f => GCompare (WrapArg g f) where
70−deriving instance Ord k => Ord (Const2 k v v')
20+ gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
71−deriving instance Show k => Show (Const2 k v v')
21+ GLT -> GLT
72−deriving instance Read k => Read (Const2 k v v)
22+ GEQ -> GEQ
23+ GGT -> GGT
73
24
74−instance Show k => GShow (Const2 k v) where
25+data Const2 :: * -> * -> * -> * where
75− gshowsPrec n x@(Const2 _) = showsPrec n x
26+ Const2 :: k -> Const2 k v v
27+ deriving (Typeable)
76
28
77instance Eq k => GEq (Const2 k v) where
29instance Eq k => GEq (Const2 k v) where
78 geq (Const2 a) (Const2 b) =
30 geq (Const2 a) (Const2 b) =
@@ -86,81 +38,13 @@ instance Ord k => GCompare (Const2 k v) where
86 EQ -> GEQ
38 EQ -> GEQ
87 GT -> GGT
39 GT -> GGT
88
40
89−-- | Convert a 'DMap' to a regular 'Map'
41+{-# INLINE sequenceDmap #-}
90−dmapToMap :: DMap (Const2 k v) Identity -> Map k v
42+sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity)
91−dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
43+sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x)
92−
44+ (return DMap.empty)
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'
99−dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
100−dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
101−
102−-- | Convert a regular 'Map' to a 'DMap'
103−mapToDMap :: Map k v -> DMap (Const2 k v) Identity
104−mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
105−
106−-- | Convert a regular 'Map', where the values are already wrapped in a functor,
107−-- to a 'DMap'
108−mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
109−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
110−
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'
118−weakenDMapWith :: (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
120−
121−--------------------------------------------------------------------------------
122−-- WrapArg
123−--------------------------------------------------------------------------------
124−
125−-- | 'WrapArg' can be used to tag a value in one functor with a type
126−-- representing another functor. This was primarily used with dependent-map <
127−-- 0.2, in which the value type was not wrapped in a separate functor.
128−data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
129− WrapArg :: f a -> WrapArg g f (g a)
130−
131−deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
132−deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
133−deriving instance Show (f a) => Show (WrapArg g f (g' a))
134−deriving instance Read (f a) => Read (WrapArg g f (g a))
135−
136−instance GEq f => GEq (WrapArg g f) where
137− geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
138−
139−instance GCompare f => GCompare (WrapArg g f) where
140− gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
141− GLT -> GLT
142− GEQ -> GEQ
143− GGT -> GGT
144−
145−--------------------------------------------------------------------------------
146−-- Convenience functions for DMap
147−--------------------------------------------------------------------------------
148−
149−-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
150−-- well as the value. The provided function MUST preserve the ordering of the
151−-- keys, or the resulting 'DMap' will be malformed.
152−mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
153−mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
154
45
155{-# INLINE combineDMapsWithKey #-}
46{-# INLINE combineDMapsWithKey #-}
156−-- | Union two 'DMap's of different types, yielding another type. Each key that
157−-- is present in either input map will be present in the output.
158−combineDMapsWithKey :: forall f g h i.
47+combineDMapsWithKey :: forall f g h i. GCompare f => (forall (a :: *). f a -> These (g a) (h a) -> i a) -> DMap f g -> DMap f h -> DMap f i
159− GCompare f
160− => (forall a. f a -> These (g a) (h a) -> i a)
161− -> DMap f g
162− -> DMap f h
163− -> DMap f i
164combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
48combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
165 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
49 where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
166 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
50 go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
@@ -170,62 +54,23 @@ combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList m
170 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
54 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
171 GGT -> (hk :=> f hk (That hv)) : go gs hs'
55 GGT -> (hk :=> f hk (That hv)) : go gs hs'
172
56
173−-- | Extract the values of a 'DMap' of 'EitherTag's.
57+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
174−dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
58+wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList
175−dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
59+
176− (Nothing, Nothing) -> Nothing
60+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
177− (Just (Identity a), Nothing) -> Just $ This a
61+rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList
178− (Nothing, Just (Identity b)) -> Just $ That b
179− (Just (Identity a), Just (Identity b)) -> Just $ These a b
180−
181−-- | Tag type for 'Either' to use it as a 'DSum'.
182−data EitherTag l r a where
183− LeftTag :: EitherTag l r l
184− RightTag :: EitherTag l r r
185− deriving (Typeable)
186
62
187−deriving instance Show (EitherTag l r a)
63+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
188−deriving instance Eq (EitherTag l r a)
64+unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList
189−deriving instance Ord (EitherTag l r a)
65+
190−
66+unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
191−instance GEq (EitherTag l r) where
67+unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]
192− geq a b = case (a, b) of
68+
193− (LeftTag, LeftTag) -> Just Refl
69+mapToDMap :: Map k v -> DMap (Const2 k v) Identity
194− (RightTag, RightTag) -> Just Refl
70+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
195− _ -> Nothing
71+
196−
72+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
197−instance GCompare (EitherTag l r) where
73+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList
198− gcompare a b = case (a, b) of
74+
199− (LeftTag, LeftTag) -> GEQ
75+dmapToMap :: DMap (Const2 k v) Identity -> Map k v
200− (LeftTag, RightTag) -> GLT
76+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
201− (RightTag, LeftTag) -> GGT
202− (RightTag, RightTag) -> GEQ
203−
204−instance GShow (EitherTag l r) where
205− gshowsPrec _ a = case a of
206− LeftTag -> showString "LeftTag"
207− RightTag -> showString "RightTag"
208−
209−-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
210−eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
211−eitherToDSum = \case
212− Left a -> (LeftTag :=> Identity a)
213− Right b -> (RightTag :=> Identity b)
214−
215−-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
216−dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
217−dsumToEither = \case
218− (LeftTag :=> Identity a) -> Left a
219− (RightTag :=> Identity b) -> Right b
220−
221−--------------------------------------------------------------------------------
222−-- ComposeMaybe
223−--------------------------------------------------------------------------------
224−
225−-- | 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
227−-- representational so that we can use safe 'coerce'.
228−newtype ComposeMaybe f a =
229− ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
230−
231−deriving instance Functor f => Functor (ComposeMaybe f)
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/DMapWithMove.hsdeleted−371
@@ -1,371 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
15−-- move values between keys.
16−module Data.Patch.DMapWithMove where
17−
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)
24−import Data.Dependent.Sum (DSum (..))
25−import qualified Data.Dependent.Map as DMap
26−import Data.Functor.Constant
27−import Data.Functor.Misc
28−import Data.Functor.Product
29−import Data.GADT.Compare (GEq (..), GCompare (..))
30−import Data.GADT.Show (GShow, gshow)
31−import qualified Data.Map as Map
32−import Data.Maybe
33−import Data.Monoid.DecidablyEmpty
34−#if !MIN_VERSION_base(4,11,0)
35−import Data.Semigroup (Semigroup (..))
36−#endif
37−import Data.Some (Some, mkSome)
38−import Data.These
39−
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
41−-- destinations.
42−--
43−-- Invariants:
44−--
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−
49−-- It won't let me derive for some reason
50−instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
51− isEmpty (PatchDMapWithMove m) = DMap.null m
52−
53−-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
54−-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
55−data NodeInfo k v a = NodeInfo
56− { _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)
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− }
61− deriving (Show)
62−
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
64−-- key (@From_Delete@), or moving a key (@From_Move@).
65−data 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
68− -- |Delete the existing key
69− 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
73− deriving (Show, Read, Eq, Ord)
74−
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.
77−type To = ComposeMaybe
78−
79−-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
80−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
81−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
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
88− noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
89− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
90− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
91− selfMove _ = Nothing
92− movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
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
100− _ ->
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
116− PatchDMapWithMove a == PatchDMapWithMove b = a == b
117−
118−-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
119−data Pair1 f g a = Pair1 (f a) (g a)
120−
121−-- |Helper data structure used for composing patches using the monoid instance.
122−data Fixup k v a
123− = Fixup_Delete
124− | Fixup_Update (These (From k v a) (To k a))
125−
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
128− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
129− where
130− 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)]
132− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
133− (Just toAfter, From_Move fromBefore)
134− | isJust $ fromBefore `geq` toAfter
135− -> [toAfter :=> Fixup_Delete]
136− | otherwise
137− -> [ toAfter :=> Fixup_Update (This editBefore)
138− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
139− ]
140− (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
141− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
142− (Nothing, _) -> []
143− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
144− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
145− | This x <- a, That y <- b
146− = Fixup_Update $ These x y
147− | That y <- a, This x <- b
148− = Fixup_Update $ These x y
149− mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
150− fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
151− combineNodeInfos _ nia nib = NodeInfo
152− { _nodeInfo_from = _nodeInfo_from nia
153− , _nodeInfo_to = _nodeInfo_to nib
154− }
155− applyFixup _ ni = \case
156− Fixup_Delete -> Nothing
157− Fixup_Update u -> Just $ NodeInfo
158− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
159− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
160− }
161− m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
162− getHere :: These a b -> Maybe a
163− getHere = \case
164− This a -> Just a
165− These a _ -> Just a
166− That _ -> Nothing
167− getThere :: These a b -> Maybe b
168− getThere = \case
169− This _ -> Nothing
170− These _ b -> Just b
171− That b -> Just b
172−
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−
178−{-
179−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
180−PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
181− where
182− getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
183− removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
184− removeRedundantDst _ a = Just a
185− f :: forall a. k a -> From k v a -> Maybe (From k v a)
186− f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
187− From_Move fromKey -> getDstAction fromKey dstBefore
188− nonMove -> nonMove
189− dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
190− getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
191− removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
192− removeRedundantSrc _ a = Just a
193− g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
194− g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
195− ComposeMaybe Nothing -> ComposeMaybe Nothing
196− ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
197− src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
198−-}
199−
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−-- @
210−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
211−moveDMapKey src dst = case src `geq` dst of
212− Nothing -> PatchDMapWithMove $ DMap.fromList
213− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
214− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
215− ]
216− Just _ -> mempty
217−
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'.
236−deleteDMapKey :: k a -> PatchDMapWithMove k v
237−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
238−
239−{-
240−k1, k2 :: Const2 Int () ()
241−k1 = Const2 1
242−k2 = Const2 2
243−p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
244−p1 = moveDMapKey k1 k2
245−p2 = moveDMapKey k2 k1
246−p12 = p1 <> p2
247−p21 = p2 <> p1
248−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
249−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
250−
251−testPatchDMapWithMove = do
252− print p1
253− print p2
254− print $ p12 == deleteDMapKey k1
255− print $ p21 == deleteDMapKey k2
256− print $ p12Slow == deleteDMapKey k1
257− print $ p21Slow == deleteDMapKey k2
258−
259−dst (PatchDMapWithMove x _) = x
260−src (PatchDMapWithMove _ x) = x
261−-}
262−
263−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
264−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
265−unPatchDMapWithMove (PatchDMapWithMove p) = p
266−
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.
270−unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
271−unsafePatchDMapWithMove = PatchDMapWithMove
272−
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'@.
282−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
283−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
284− DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
285− where g :: forall a. From k v a -> From k v' a
286− g = \case
287− From_Insert v -> From_Insert $ f v
288− From_Delete -> From_Delete
289− From_Move k -> From_Move k
290−
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')@.
292−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
293−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
294−
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')@.
296−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
297−traversePatchDMapWithMoveWithKey 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)
299− g k = \case
300− From_Insert v -> From_Insert <$> f k v
301− From_Delete -> pure From_Delete
302− From_Move fromKey -> pure $ From_Move fromKey
303−
304−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
305−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
306−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
307−
308−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
309−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
310−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
311−
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.
314−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
315−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
316− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
317− g ni = MapWithMove.NodeInfo
318− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
319− From_Insert v -> MapWithMove.From_Insert $ f v
320− From_Delete -> MapWithMove.From_Delete
321− From_Move k -> MapWithMove.From_Move $ mkSome k
322− , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
323− }
324−
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'
328−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
329− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
330− g ni = MapWithMove.NodeInfo
331− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
332− From_Insert v -> MapWithMove.From_Insert $ f v
333− From_Delete -> MapWithMove.From_Delete
334− From_Move (Const2 k) -> MapWithMove.From_Move k
335− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
336− }
337−
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'
342−const2PatchDMapWithMoveWith 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')
344− g (k, ni) = Const2 k :=> NodeInfo
345− { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
346− MapWithMove.From_Insert v -> From_Insert $ f v
347− MapWithMove.From_Delete -> From_Delete
348− MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
349− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
350− }
351−
352−-- | Apply the insertions, deletions, and moves to a given 'DMap'.
353−instance GCompare k => Patch (PatchDMapWithMove k v) where
354− 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?
356− where insertions = DMap.mapMaybeWithKey insertFunc p
357− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
358− insertFunc _ ni = case _nodeInfo_from ni of
359− From_Insert v -> Just v
360− From_Move k -> DMap.lookup k old
361− From_Delete -> Nothing
362− deletions = DMap.mapMaybeWithKey deleteFunc p
363− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
364− deleteFunc _ ni = case _nodeInfo_from ni of
365− From_Delete -> Just $ Constant ()
366− _ -> Nothing
367−
368−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
369−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
370−getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
371− where f _ v ni = Pair v $ _nodeInfo_to ni
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/Map.hsdeleted−72
@@ -1,72 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−{-# LANGUAGE TemplateHaskell #-}
9−{-# LANGUAGE TypeFamilies #-}
10−
11−-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
12−-- and deletions
13−module Data.Patch.Map where
14−
15−import Data.Patch.Class
16−
17−import Control.Lens
18−import Data.Map (Map)
19−import qualified Data.Map as Map
20−import Data.Maybe
21−import Data.Monoid.DecidablyEmpty
22−import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
23−
24−-- | 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
26−-- deletions are represented as 'Nothing's
27−newtype 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−
47−-- | Apply the insertions or deletions to a given 'Map'.
48−instance Ord k => Patch (PatchMap k v) where
49− type PatchTarget (PatchMap k v) = Map k v
50− {-# INLINABLE apply #-}
51− apply (PatchMap 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?
52− where insertions = Map.mapMaybeWithKey (const id) p
53− deletions = Map.mapMaybeWithKey (const nothingToJust) p
54− nothingToJust = \case
55− Nothing -> Just ()
56− Just _ -> Nothing
57−
58−instance FunctorWithIndex k (PatchMap k)
59−instance FoldableWithIndex k (PatchMap k)
60−instance TraversableWithIndex k (PatchMap k) where
61− itraverse = itraversed . Indexed
62− itraversed = _Wrapped .> itraversed <. traversed
63−
64−-- | Returns all the new elements that will be added to the 'Map'
65−patchMapNewElements :: PatchMap k v -> [v]
66−patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
67−
68−-- | Returns all the new elements that will be added to the 'Map'
69−patchMapNewElementsMap :: PatchMap k v -> Map k v
70−patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
71−
72−makeWrapped ''PatchMap
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/Reflex.hsnew file+10
@@ -0,0 +1,10 @@
1+module Reflex ( module Reflex.Class
2+ , module Reflex.Dynamic
3+ , module Reflex.Dynamic.TH
4+ , module Reflex.Spider
5+ ) where
6+
7+import Reflex.Class
8+import Reflex.Dynamic
9+import Reflex.Dynamic.TH
10+import Reflex.Spider
src/Reflex/Class.hsnew file+374
@@ -0,0 +1,374 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, CPP #-}
2+module Reflex.Class where
3+
4+import Control.Applicative
5+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
6+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
7+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
8+import Control.Monad.Trans.Writer (WriterT())
9+import Control.Monad.Trans.Except (ExceptT())
10+import Control.Monad.Trans.Cont (ContT())
11+import Control.Monad.Trans.RWS (RWST())
12+import Data.List.NonEmpty (NonEmpty (..))
13+import Data.These
14+import Data.Align
15+import Data.GADT.Compare (GEq (..), (:~:) (..))
16+import Data.GADT.Show (GShow (..))
17+import Data.Dependent.Sum (ShowTag (..))
18+import Data.Map (Map)
19+import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
20+import qualified Data.Dependent.Map as DMap
21+import Data.Functor.Misc
22+import Data.Semigroup
23+import Data.Traversable
24+
25+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
26+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
27+
28+import Debug.Trace (trace)
29+
30+class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where
31+ -- | A container for a value that can change over time. Behaviors can be sampled at will, but it is not possible to be notified when they change
32+ data Behavior t :: * -> *
33+ -- | A stream of occurrences. During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")
34+ data Event t :: * -> *
35+ -- | An Event with no occurrences
36+ never :: Event t a
37+ -- | Create a Behavior that always has the given value
38+ 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 Behaviors doesn't have a negative performance impact
39+ -- | Create an Event from another Event; the provided function can sample Behaviors and hold Events, and use the results to produce a occurring (Just) or non-occurring (Nothing) result
40+ push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
41+ -- | A monad for doing complex push-based calculations efficiently
42+ type PushM t :: * -> *
43+ -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes
44+ pull :: PullM t a -> Behavior t a
45+ -- | A monad for doing complex pull-based calculations efficiently
46+ type PullM t :: * -> *
47+ -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously
48+ 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
49+ -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
50+ 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
51+ -- | Create an Event that will occur whenever the currently-selected input Event occurs
52+ switch :: Behavior t (Event t a) -> Event t a
53+ -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
54+ coincidence :: Event t (Event t a) -> Event t a
55+
56+class (Applicative m, Monad m) => MonadSample t m | m -> t where
57+ -- | Get the current value in the Behavior
58+ sample :: Behavior t a -> m a
59+
60+class MonadSample t m => MonadHold t m where
61+ -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs. The update takes effect immediately after the Event occurs; if the occurrence that sets the Behavior (or one that is simultaneous with it) is used to sample the Behavior, it will see the *old* value of the Behavior, not the new one.
62+ hold :: a -> Event t a -> m (Behavior t a)
63+
64+newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
65+
66+--------------------------------------------------------------------------------
67+-- Instances
68+--------------------------------------------------------------------------------
69+
70+instance MonadSample t m => MonadSample t (ReaderT r m) where
71+ sample = lift . sample
72+
73+instance MonadHold t m => MonadHold t (ReaderT r m) where
74+ hold a0 = lift . hold a0
75+
76+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
77+ sample = lift . sample
78+
79+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
80+ hold a0 = lift . hold a0
81+
82+instance MonadSample t m => MonadSample t (StateT s m) where
83+ sample = lift . sample
84+
85+instance MonadHold t m => MonadHold t (StateT s m) where
86+ hold a0 = lift . hold a0
87+
88+instance MonadSample t m => MonadSample t (ExceptT e m) where
89+ sample = lift . sample
90+
91+instance MonadHold t m => MonadHold t (ExceptT e m) where
92+ hold a0 = lift . hold a0
93+
94+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
95+ sample = lift . sample
96+
97+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
98+ hold a0 = lift . hold a0
99+
100+instance MonadSample t m => MonadSample t (ContT r m) where
101+ sample = lift . sample
102+
103+instance MonadHold t m => MonadHold t (ContT r m) where
104+ hold a0 = lift . hold a0
105+
106+--------------------------------------------------------------------------------
107+-- Convenience functions
108+--------------------------------------------------------------------------------
109+
110+-- | Create an Event from another Event.
111+-- The provided function can sample 'Behavior's and hold 'Event's.
112+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
113+pushAlways f = push (liftM Just . f)
114+
115+-- | Flipped version of 'fmap'.
116+ffor :: Functor f => f a -> (a -> b) -> f b
117+ffor = flip fmap
118+
119+instance Reflex t => Functor (Behavior t) where
120+ fmap f = pull . liftM f . sample
121+
122+instance Reflex t => Applicative (Behavior t) where
123+ pure = constant
124+ f <*> x = pull $ sample f `ap` sample x
125+ _ *> b = b
126+ a <* _ = a
127+
128+instance Reflex t => Monad (Behavior t) where
129+ a >>= f = pull $ sample a >>= sample . f
130+ -- 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 Behaviors other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.
131+ return = constant
132+ fail = error "Monad (Behavior t) does not support fail"
133+
134+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
135+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
136+ sconcat = pull . liftM sconcat . mapM sample
137+#if MIN_VERSION_semigroups(0,17,0)
138+ stimes n = fmap $ stimes n
139+#else
140+ times1p n = fmap $ times1p n
141+#endif
142+
143+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
144+ mempty = constant mempty
145+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
146+ mconcat = pull . liftM mconcat . mapM sample
147+
148+--TODO: See if there's a better class in the standard libraries already
149+-- | A class for values that combines filtering and mapping using 'Maybe'.
150+class FunctorMaybe f where
151+ -- | Combined mapping and filtering function.
152+ fmapMaybe :: (a -> Maybe b) -> f a -> f b
153+
154+-- | Flipped version of 'fmapMaybe'.
155+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
156+fforMaybe = flip fmapMaybe
157+
158+-- | Filter 'f a' using the provided predicate.
159+-- Relies on 'fforMaybe'.
160+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
161+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
162+
163+instance Reflex t => FunctorMaybe (Event t) where
164+ fmapMaybe f = push $ return . f
165+
166+instance Reflex t => Functor (Event t) where
167+ fmap f = fmapMaybe $ Just . f
168+
169+-- | Create a new 'Event' by combining each occurence with the next value
170+-- of the list using the supplied function. If the list runs out of items,
171+-- all subsequent 'Event' occurrences will be ignored.
172+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
173+zipListWithEvent f l e = do
174+ rec lb <- hold l eTail
175+ let eBoth = flip push e $ \o -> do
176+ l' <- sample lb
177+ return $ case l' of
178+ (h : t) -> Just (f h o, t)
179+ [] -> Nothing
180+ let eTail = fmap snd eBoth
181+ lb `seq` eBoth `seq` eTail `seq` return ()
182+ return $ fmap fst eBoth
183+
184+-- | Replace each occurrence value of the 'Event' with the value of the
185+-- 'Behavior' at the time of that occurrence.
186+tag :: Reflex t => Behavior t b -> Event t a -> Event t b
187+tag b = pushAlways $ \_ -> sample b
188+
189+-- | Create a new 'Event' that combines occurences of supplied 'Event'
190+-- with the current value of the 'Behavior'.
191+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
192+attach = attachWith (,)
193+
194+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
195+-- by combining it with the current value of the 'Behavior'.
196+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
197+attachWith f = attachWithMaybe $ \a b -> Just $ f a b
198+
199+-- | Create a new 'Event' by combining each occurence with the current
200+-- value of the 'Behavior'. The occurrence is discarded if the combining function
201+-- returns Nothing
202+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
203+attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
204+
205+-- | Alias for 'headE'
206+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
207+onceE = headE
208+
209+-- | Create a new 'Event' that only occurs on the first occurence of
210+-- the supplied 'Event'.
211+headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
212+headE e = do
213+ rec be <- hold e $ fmap (const never) e'
214+ let e' = switch be
215+ e' `seq` return ()
216+ return e'
217+
218+-- | Create a new 'Event' that occurs on all but the first occurence
219+-- of the supplied 'Event'.
220+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
221+tailE e = liftM snd $ headTailE e
222+
223+-- | Create a tuple of two 'Event's with the first one occuring only
224+-- the first time the supplied 'Event' occurs and the second occuring
225+-- on all but the first occurence.
226+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
227+headTailE e = do
228+ eHead <- headE e
229+ be <- hold never $ fmap (const e) eHead
230+ return (eHead, switch be)
231+
232+-- | Split the supplied 'Event' into two individual 'Event's occuring
233+-- at the same time with the respective values from the tuple.
234+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
235+splitE e = (fmap fst e, fmap snd e)
236+
237+-- | Print the supplied 'String' and the value of the 'Event' on each
238+-- occurence. This should /only/ be used for debugging.
239+--
240+-- Note: As with Debug.Trace.trace, the message will only be printed if
241+-- the 'Event' is actually used.
242+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
243+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
244+
245+-- | Print the output of the supplied function on each occurence of
246+-- the 'Event'. This should /only/ be used for debugging.
247+--
248+-- Note: As with Debug.Trace.trace, the message will only be printed if
249+-- the 'Event' is actually used.
250+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
251+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
252+
253+-- | Tag type for 'Either' to use it as a 'DSum'.
254+data EitherTag l r a where
255+ LeftTag :: EitherTag l r l
256+ RightTag :: EitherTag l r r
257+
258+instance GEq (EitherTag l r) where
259+ geq a b = case (a, b) of
260+ (LeftTag, LeftTag) -> Just Refl
261+ (RightTag, RightTag) -> Just Refl
262+ _ -> Nothing
263+
264+instance GCompare (EitherTag l r) where
265+ gcompare a b = case (a, b) of
266+ (LeftTag, LeftTag) -> GEQ
267+ (LeftTag, RightTag) -> GLT
268+ (RightTag, LeftTag) -> GGT
269+ (RightTag, RightTag) -> GEQ
270+
271+instance GShow (EitherTag l r) where
272+ gshowsPrec _ a = case a of
273+ LeftTag -> showString "LeftTag"
274+ RightTag -> showString "RightTag"
275+
276+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
277+ showTaggedPrec t n (Identity a) = case t of
278+ LeftTag -> showsPrec n a
279+ RightTag -> showsPrec n a
280+
281+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
282+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
283+eitherToDSum = \case
284+ Left a -> (LeftTag :=> Identity a)
285+ Right b -> (RightTag :=> Identity b)
286+
287+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
288+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
289+dsumToEither = \case
290+ (LeftTag :=> Identity a) -> Left a
291+ (RightTag :=> Identity b) -> Right b
292+
293+-- | Extract the values of a 'DMap' of 'EitherTag's.
294+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
295+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
296+ (Nothing, Nothing) -> Nothing
297+ (Just (Identity a), Nothing) -> Just $ This a
298+ (Nothing, Just (Identity b)) -> Just $ That b
299+ (Just (Identity a), Just (Identity b)) -> Just $ These a b
300+
301+-- | Create a new 'Event' that occurs if at least one of the supplied
302+-- 'Event's occurs. If both occur at the same time they are combined
303+-- using 'mappend'.
304+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
305+appendEvents e1 e2 = mergeThese mappend <$> align e1 e2
306+
307+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
308+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
309+sequenceThese t = case t of
310+ This ma -> liftM This ma
311+ These ma mb -> liftM2 These ma mb
312+ That mb -> liftM That mb
313+
314+instance (Semigroup a, Reflex t) => Monoid (Event t a) where
315+ mempty = never
316+ mappend a b = mconcat [a, b]
317+ mconcat = fmap sconcat . mergeList
318+
319+-- | Create a new 'Event' that occurs if at least one of the 'Event's
320+-- in the list occurs. If multiple occur at the same time they are
321+-- folded from the left with the given function.
322+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
323+mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)
324+ . merge
325+ . DMap.fromDistinctAscList
326+ . map (\(k, v) -> (Const2 k) :=> v)
327+ $ zip [0 :: Int ..] es
328+
329+-- | Create a new 'Event' that occurs if at least one of the 'Event's
330+-- in the list occurs. If multiple occur at the same time the value is
331+-- the value of the leftmost event.
332+leftmost :: Reflex t => [Event t a] -> Event t a
333+leftmost = mergeWith const
334+
335+-- | Create a new 'Event' that occurs if at least one of the 'Event's
336+-- in the list occurs and has a list of the values of all 'Event's
337+-- occuring at that time.
338+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
339+mergeList [] = never
340+mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
341+
342+-- | Create a new 'Event' combining the map of 'Event's into an
343+-- 'Event' that occurs if at least one of them occurs and has a map of
344+-- values of all 'Event's occuring at that time.
345+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
346+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
347+
348+-- | Split the event into an 'EventSelector' that allows efficient
349+-- selection of the individual 'Event's.
350+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
351+fanMap = fan . fmap mapToDMap
352+
353+-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to
354+switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
355+switchPromptly ea0 eea = do
356+ bea <- hold ea0 eea
357+ let eLag = switch bea
358+ eCoincidences = coincidence eea
359+ return $ leftmost [eCoincidences, eLag]
360+
361+instance Reflex t => Align (Event t) where
362+ nil = never
363+ align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
364+
365+-- | Create a new 'Event' that only occurs if the supplied 'Event'
366+-- occurs and the 'Behavior' is true at the time of occurence.
367+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
368+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
369+
370+-- | Create a new behavior given a starting behavior and switch to a the
371+-- behvior carried by the event when it fires.
372+switcher :: (Reflex t, MonadHold t m)
373+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
374+switcher b eb = pull . (sample <=< sample) <$> hold b eb
src/Reflex/Dynamic.hsnew file+524
@@ -0,0 +1,524 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}
2+module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
3+ , current
4+ , updated
5+ , constDyn
6+ , holdDyn
7+ , nubDyn
8+ , count
9+ , toggle
10+ , switchPromptlyDyn
11+ , tagDyn
12+ , attachDyn
13+ , attachDynWith
14+ , attachDynWithMaybe
15+ , mapDyn
16+ , forDyn
17+ , mapDynM
18+ , foldDyn
19+ , foldDynM
20+ , foldDynMaybe
21+ , foldDynMaybeM
22+ , combineDyn
23+ , collectDyn
24+ , mconcatDyn
25+ , distributeDMapOverDyn
26+ , joinDyn
27+ , joinDynThroughMap
28+ , traceDyn
29+ , traceDynWith
30+ , splitDyn
31+ , Demux
32+ , demux
33+ , getDemuxed
34+ -- Things that probably aren't very useful:
35+ , HList (..)
36+ , FHList (..)
37+ , distributeFHListOverDyn
38+ -- Unsafe
39+ , unsafeDynamic
40+ ) where
41+
42+import Prelude hiding (mapM, mapM_)
43+
44+import Reflex.Class
45+import Data.Functor.Misc
46+
47+import Control.Monad hiding (mapM, mapM_, forM, forM_)
48+import Control.Monad.Fix
49+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)
50+import Data.These
51+import Data.Traversable (mapM, forM)
52+import Data.Align
53+import Data.Map (Map)
54+import qualified Data.Map as Map
55+import Data.Dependent.Map (DMap)
56+import qualified Data.Dependent.Map as DMap
57+import Data.Dependent.Sum (DSum (..))
58+import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))
59+import Data.Monoid
60+--import Data.HList (HList (..), hBuild)
61+
62+data HList (l::[*]) where
63+ HNil :: HList '[]
64+ HCons :: e -> HList l -> HList (e ': l)
65+
66+infixr 2 `HCons`
67+
68+type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
69+type instance HRevApp '[] l = l
70+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
71+
72+hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
73+hRevApp HNil l = l
74+hRevApp (HCons x l) l' = hRevApp l (HCons x l')
75+
76+hReverse :: HList l -> HList (HRevApp l '[])
77+hReverse l = hRevApp l HNil
78+
79+hBuild :: (HBuild' '[] r) => r
80+hBuild = hBuild' HNil
81+
82+class HBuild' l r where
83+ hBuild' :: HList l -> r
84+
85+instance (l' ~ HRevApp l '[])
86+ => HBuild' l (HList l') where
87+ hBuild' l = hReverse l
88+
89+instance HBuild' (a ': l) r
90+ => HBuild' l (a->r) where
91+ hBuild' l x = hBuild' (HCons x l)
92+
93+-- | A container for a value that can change over time and allows notifications on changes.
94+-- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
95+-- change if and only if the Event fires.
96+--
97+-- Although @Dynamic@ logically has a 'Functor' instance, currently it can\'t
98+-- be implemented without potentially requiring the mapped function to be
99+-- evaluated twice. Instead, you can use 'mapDyn', which runs in a 'MonadHold'
100+-- instance, to achieve the same result.
101+data Dynamic t a
102+ = Dynamic (Behavior t a) (Event t a)
103+
104+unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
105+unsafeDynamic = Dynamic
106+
107+-- | Extract the 'Behavior' of a 'Dynamic'.
108+current :: Dynamic t a -> Behavior t a
109+current (Dynamic b _) = b
110+
111+-- | Extract the 'Event' of the 'Dynamic'.
112+updated :: Dynamic t a -> Event t a
113+updated (Dynamic _ e) = e
114+
115+-- | 'Dynamic' with the constant supplied value.
116+constDyn :: Reflex t => a -> Dynamic t a
117+constDyn x = Dynamic (constant x) never
118+
119+-- | Create a 'Dynamic' using the initial value that changes every
120+-- time the 'Event' occurs.
121+holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
122+holdDyn v0 e = do
123+ b <- hold v0 e
124+ return $ Dynamic b e
125+
126+-- | Create a new 'Dynamic' that only signals changes if the values
127+-- actually changed.
128+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
129+nubDyn d =
130+ let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
131+ in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
132+
133+{-
134+instance Reflex t => Functor (Dynamic t) where
135+ fmap f d =
136+ let e' = fmap f $ updated d
137+ eb' = push (\b' -> liftM Just $ constant b') e'
138+ b0 = fmap f $ current d
139+
140+-}
141+
142+-- | Map a function over a 'Dynamic'.
143+mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
144+mapDyn f = mapDynM $ return . f
145+
146+-- | Flipped version of 'mapDyn'.
147+forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
148+forDyn = flip mapDyn
149+
150+-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can
151+-- perform is 'sample'.
152+{-# INLINE mapDynM #-}
153+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)
154+mapDynM f d = do
155+ let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d
156+ eb' = fmap constant e'
157+ v0 = pull $ f =<< sample (current d)
158+ bb' :: Behavior t (Behavior t b) <- hold v0 eb'
159+ let b' = pull $ sample =<< sample bb'
160+ return $ Dynamic b' e'
161+
162+-- | Create a 'Dynamic' using the initial value and change it each
163+-- time the 'Event' occurs using a folding function on the previous
164+-- value and the value of the 'Event'.
165+foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
166+foldDyn f = foldDynMaybe $ \o v -> Just $ f o v
167+
168+-- | Create a 'Dynamic' using the initial value and change it each
169+-- time the 'Event' occurs using a monadic folding function on the
170+-- previous value and the value of the 'Event'.
171+foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
172+foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v
173+
174+foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
175+foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
176+
177+foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
178+foldDynMaybeM f z e = do
179+ rec let e' = flip push e $ \o -> do
180+ v <- sample b'
181+ f o v
182+ b' <- hold z e'
183+ return $ Dynamic b' e'
184+
185+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
186+count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
187+count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
188+
189+-- | Create a new 'Dynamic' using the initial value that flips its
190+-- value every time the 'Event' occurs.
191+toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
192+toggle = foldDyn (const not)
193+
194+-- | Switches to the new 'Event' whenever it receives one. Switching
195+-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new
196+-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.
197+switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
198+switchPromptlyDyn de =
199+ let eLag = switch $ current de
200+ eCoincidences = coincidence $ updated de
201+ in leftmost [eCoincidences, eLag]
202+
203+{-
204+
205+mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)
206+mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb
207+
208+firstE :: (Reflex t m) => [Event t a] -> m (Event t a)
209+firstE [] = return never
210+firstE (h:t) = mergeEventsLeftBiased h =<< firstE t
211+
212+concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
213+concatEventsWith _ [] = return never
214+concatEventsWith _ [e] = return e
215+concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
216+--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
217+
218+mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
219+mconcatE = concatEventsWith mappend
220+-}
221+
222+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
223+-- respective value of the tuple.
224+splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
225+splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
226+
227+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
228+mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
229+mconcatDyn es = do
230+ ddm :: Dynamic t (DMap (Const2 Int a) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es
231+ mapDyn (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) ddm
232+
233+-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
234+-- Dynamic values.
235+distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
236+distributeDMapOverDyn dm = case DMap.toList dm of
237+ [] -> return $ constDyn DMap.empty
238+ [k :=> v] -> mapDyn (DMap.singleton k . Identity) v
239+ _ -> do
240+ let edmPre = merge $ rewrapDMap updated dm
241+ edm :: Event t (DMap k Identity) = flip push edmPre $ \o -> return . Just =<< do
242+ let f _ = \case
243+ This origDyn -> sample $ current origDyn
244+ That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"
245+ These _ (Identity newVal) -> return newVal
246+ sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)
247+ dm0 :: Behavior t (DMap k Identity) = pull $ do
248+ liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv
249+ bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm
250+ let bdm = pull $ sample =<< sample bbdm
251+ return $ Dynamic bdm edm
252+
253+-- | Merge two 'Dynamic's into a new one using the provided
254+-- function. The new 'Dynamic' changes its value each time one of the
255+-- original 'Dynamic's changes its value.
256+combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
257+combineDyn f da db = do
258+ let eab = align (updated da) (updated db)
259+ ec = flip push eab $ \o -> do
260+ (a, b) <- case o of
261+ This a -> do
262+ b <- sample $ current db
263+ return (a, b)
264+ That b -> do
265+ a <- sample $ current da
266+ return (a, b)
267+ These a b -> return (a, b)
268+ return $ Just $ f a b
269+ c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)
270+ bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec
271+ let bc :: Behavior t c = pull $ sample =<< sample bbc
272+ return $ Dynamic bc ec
273+
274+{-
275+tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a
276+tagInnerDyn e =
277+ let eSlow = push (liftM Just . sample . current) e
278+ eFast = coincidence $ fmap updated e
279+ in leftmost [eFast, eSlow]
280+-}
281+
282+-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value
283+-- of the inner 'Dynamic'.
284+joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
285+joinDyn dd =
286+ let b' = pull $ sample . current =<< sample (current dd)
287+ eOuter :: Event t a = pushAlways (sample . current) $ updated dd
288+ eInner :: Event t a = switch $ fmap updated (current dd)
289+ eBoth :: Event t a = coincidence $ fmap updated (updated dd)
290+ e' = leftmost [eBoth, eOuter, eInner]
291+ in Dynamic b' e'
292+
293+--TODO: Generalize this to functors other than Maps
294+-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
295+-- with the current values of the 'Dynamic's in a map.
296+joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
297+joinDynThroughMap dd =
298+ let b' = pull $ mapM (sample . current) =<< sample (current dd)
299+ eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd
300+ eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased
301+ readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a
302+ readNonFiring = \case
303+ This d -> sample $ current d
304+ That a -> return a
305+ These _ a -> return a
306+ eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)
307+ e' = leftmost [eBoth, eOuter, eInner]
308+ in Dynamic b' e'
309+
310+-- | Print the value of the 'Dynamic' on each change and prefix it
311+-- with the provided string. This should /only/ be used for debugging.
312+--
313+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
314+-- else in the system is depending on it.
315+traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
316+traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
317+
318+-- | Print the result of applying the provided function to the value
319+-- of the 'Dynamic' on each change. This should /only/ be used for
320+-- debugging.
321+--
322+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
323+-- else in the system is depending on it.
324+traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
325+traceDynWith f d =
326+ let e' = traceEventWith f $ updated d
327+ in Dynamic (current d) e'
328+
329+-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
330+-- each time the 'Event' occurs.
331+--
332+-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing
333+-- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d`
334+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
335+-- will be used, since the 'Behavior' won't be updated until the end of the frame.
336+-- Additionally, this means that the output 'Event' may not be used to directly change
337+-- the input 'Dynamic', because that would mean its value depends on itself. When creating
338+-- cyclic data flows, generally `tag (current d) e` is preferred.
339+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
340+tagDyn = attachDynWith const
341+
342+-- | Attach the current value of the 'Dynamic' to the value of the
343+-- 'Event' each time it occurs.
344+--
345+-- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details.
346+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
347+attachDyn = attachDynWith (,)
348+
349+-- | Combine the current value of the 'Dynamic' with the value of the
350+-- 'Event' each time it occurs.
351+--
352+-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details.
353+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
354+attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
355+
356+-- | Create a new 'Event' by combining the value at each occurence
357+-- with the current value of the 'Dynamic' value and possibly
358+-- filtering if the combining function returns 'Nothing'.
359+--
360+-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details.
361+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
362+attachDynWithMaybe f d e =
363+ let e' = attach (current d) e
364+ in fforMaybe (align e' $ updated d) $ \case
365+ This (a, b) -> f a b -- Only the tagging event is firing, so use that
366+ These (_, b) a -> f a b -- Both events are firing, so use the newer value
367+ That _ -> Nothing -- The tagging event isn't firing, so don't fire
368+
369+--------------------------------------------------------------------------------
370+-- Demux
371+--------------------------------------------------------------------------------
372+
373+-- | Represents a time changing value together with an 'EventSelector'
374+-- that can efficiently detect when the underlying Dynamic has a particular value.
375+-- This is useful for representing data like the current selection of a long list.
376+--
377+-- Semantically,
378+-- > getDemuxed (demux d) k === mapDyn (== k) d
379+-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,
380+-- rather than /O(n)/ for mapDyn.
381+data Demux t k = Demux { demuxValue :: Behavior t k
382+ , demuxSelector :: EventSelector t (Const2 k Bool)
383+ }
384+
385+-- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.
386+demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
387+demux k = Demux (current k)
388+ (fan $ attachWith (\k0 k1 -> if k0 == k1
389+ then DMap.empty
390+ else DMap.fromList [Const2 k0 :=> Identity False,
391+ Const2 k1 :=> Identity True])
392+ (current k) (updated k))
393+
394+--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
395+-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
396+-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
397+getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
398+getDemuxed d k = do
399+ let e = select (demuxSelector d) (Const2 k)
400+ bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e
401+ let b = pull $ join $ sample bb
402+ return $ Dynamic b e
403+
404+--------------------------------------------------------------------------------
405+-- collectDyn
406+--------------------------------------------------------------------------------
407+
408+--TODO: This whole section is badly in need of cleanup
409+
410+data FHList f l where
411+ FHNil :: FHList f '[]
412+ FHCons :: f e -> FHList f l -> FHList f (e ': l)
413+
414+instance GEq (HListPtr l) where
415+ HHeadPtr `geq` HHeadPtr = Just Refl
416+ HHeadPtr `geq` HTailPtr _ = Nothing
417+ HTailPtr _ `geq` HHeadPtr = Nothing
418+ HTailPtr a `geq` HTailPtr b = a `geq` b
419+
420+instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
421+ HHeadPtr `gcompare` HHeadPtr = GEQ
422+ HHeadPtr `gcompare` HTailPtr _ = GLT
423+ HTailPtr _ `gcompare` HHeadPtr = GGT
424+ HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
425+
426+data HListPtr l a where
427+ HHeadPtr :: HListPtr (h ': t) h
428+ HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
429+
430+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
431+fhlistToDMap = DMap.fromList . go
432+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
433+ go = \case
434+ FHNil -> []
435+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t)
436+
437+class RebuildSortedHList l where
438+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
439+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
440+
441+instance RebuildSortedHList '[] where
442+ rebuildSortedFHList l = case l of
443+ [] -> FHNil
444+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
445+ rebuildSortedHList l = case l of
446+ [] -> HNil
447+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
448+
449+instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
450+ rebuildSortedFHList l = case l of
451+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
452+ _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
453+ rebuildSortedHList l = case l of
454+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
455+ _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
456+
457+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
458+dmapToHList = rebuildSortedHList . DMap.toList
459+
460+distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
461+distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)
462+{-
463+distributeFHListOverDyn l = do
464+ let ec = undefined
465+ c0 = pull $ sequenceFHList $ natMap (sample . current) l
466+ bbc <- hold c0 $ fmap constant ec
467+ let bc = pull $ sample =<< sample bbc
468+ return $ Dynamic bc ec
469+-}
470+
471+class AllAreFunctors (f :: a -> *) (l :: [a]) where
472+ type FunctorList f l :: [*]
473+ toFHList :: HList (FunctorList f l) -> FHList f l
474+ fromFHList :: FHList f l -> HList (FunctorList f l)
475+
476+instance AllAreFunctors f '[] where
477+ type FunctorList f '[] = '[]
478+ toFHList l = case l of
479+ HNil -> FHNil
480+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
481+ fromFHList FHNil = HNil
482+
483+instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
484+ type FunctorList f (h ': t) = f h ': FunctorList f t
485+ toFHList l = case l of
486+ a `HCons` b -> a `FHCons` toFHList b
487+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
488+ fromFHList (a `FHCons` b) = a `HCons` fromFHList b
489+
490+collectDyn :: ( RebuildSortedHList (HListElems b)
491+ , IsHList a, IsHList b
492+ , AllAreFunctors (Dynamic t) (HListElems b)
493+ , Reflex t, MonadHold t m
494+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
495+ ) => a -> m (Dynamic t b)
496+collectDyn ds =
497+ mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)
498+
499+-- Poor man's Generic
500+class IsHList a where
501+ type HListElems a :: [*]
502+ toHList :: a -> HList (HListElems a)
503+ fromHList :: HList (HListElems a) -> a
504+
505+instance IsHList (a, b) where
506+ type HListElems (a, b) = [a, b]
507+ toHList (a, b) = hBuild a b
508+ fromHList l = case l of
509+ a `HCons` b `HCons` HNil -> (a, b)
510+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
511+
512+instance IsHList (a, b, c, d) where
513+ type HListElems (a, b, c, d) = [a, b, c, d]
514+ toHList (a, b, c, d) = hBuild a b c d
515+ fromHList l = case l of
516+ a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
517+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
518+
519+instance IsHList (a, b, c, d, e, f) where
520+ type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
521+ toHList (a, b, c, d, e, f) = hBuild a b c d e f
522+ fromHList l = case l of
523+ a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
524+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
src/Reflex/Dynamic/TH.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls, PatternGuards #-}
2+module Reflex.Dynamic.TH (qDyn, unqDyn, mkDyn) where
3+
4+import Reflex.Dynamic
5+
6+import Language.Haskell.TH
7+import qualified Language.Haskell.TH.Syntax as TH
8+import Language.Haskell.TH.Quote
9+import Data.Data
10+import Control.Monad.State
11+import qualified Language.Haskell.Exts as Hs
12+import qualified Language.Haskell.Meta.Syntax.Translate as Hs
13+import Data.Monoid
14+import Data.Generics
15+
16+-- | Quote a Dynamic expression. Within the quoted expression, you can use '$(unqDyn [| x |])' to refer to any expression 'x' of type 'Dynamic t a'; the unquoted result will be of type 'a'
17+qDyn :: Q Exp -> Q Exp
18+qDyn qe = do
19+ e <- qe
20+ let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
21+ f d = case eqT of
22+ Just (Refl :: d :~: Exp)
23+ | AppE (VarE m) eInner <- d
24+ , m == 'unqMarker
25+ -> do n <- lift $ newName "dynamicQuotedExpressionVariable"
26+ modify ((n, eInner):)
27+ return $ VarE n
28+ _ -> gmapM f d
29+ (e', exprsReversed) <- runStateT (gmapM f e) []
30+ let exprs = reverse exprsReversed
31+ arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs
32+ param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs
33+ [| mapDyn $(return $ LamE [param] e') =<< distributeFHListOverDyn $(return arg) |]
34+
35+unqDyn :: Q Exp -> Q Exp
36+unqDyn e = [| unqMarker $e |]
37+
38+-- | This type represents an occurrence of unqDyn before it has been processed by qDyn. If you see it in a type error, it probably means that unqDyn has been used outside of a qDyn context.
39+data UnqDyn
40+
41+-- unqMarker must not be exported; it is used only as a way of smuggling data from unqDyn to qDyn
42+--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
43+unqMarker :: a -> UnqDyn
44+unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
45+
46+mkDyn :: QuasiQuoter
47+mkDyn = QuasiQuoter
48+ { quoteExp = mkDynExp
49+ , quotePat = error "mkDyn: pattern splices are not supported"
50+ , quoteType = error "mkDyn: type splices are not supported"
51+ , quoteDec = error "mkDyn: declaration splices are not supported"
52+ }
53+
54+mkDynExp :: String -> Q Exp
55+mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
56+ Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
57+ Hs.ParseOk e -> qDyn $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
58+ where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
59+ antiE x = case x of
60+ Hs.SpliceExp se ->
61+ Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
62+ Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
63+ Hs.ParenSplice ps -> ps
64+ _ -> x
65+ reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
66+ | modName == modName' && occName == occName' = 'unqMarker
67+ reinstateUnqDyn x = x
src/Reflex/Host/Class.hsnew file+227
@@ -0,0 +1,227 @@
1+{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies, FlexibleContexts #-}
2+module Reflex.Host.Class where
3+
4+import Reflex.Class
5+
6+import Control.Applicative
7+import Control.Monad
8+import Control.Monad.Fix
9+import Control.Monad.Identity
10+import Control.Monad.Trans
11+import Control.Monad.Trans.Reader (ReaderT())
12+import Control.Monad.Trans.Writer (WriterT())
13+import Control.Monad.Trans.Cont (ContT())
14+import Control.Monad.Trans.Except (ExceptT())
15+import Control.Monad.Trans.RWS (RWST())
16+import Control.Monad.Trans.State (StateT())
17+import qualified Control.Monad.Trans.State.Strict as Strict
18+import Data.Dependent.Sum (DSum (..))
19+import Data.Monoid
20+import Data.GADT.Compare
21+import Control.Monad.Ref
22+
23+-- Note: this import must come last to silence warnings from AMP
24+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
25+
26+-- | Framework implementation support class for the reflex implementation represented by @t@.
27+class (Reflex t, MonadReflexCreateTrigger t (HostFrame t), MonadSample t (HostFrame t), MonadHold t (HostFrame t), MonadFix (HostFrame t), MonadSubscribeEvent t (HostFrame t)) => ReflexHost t where
28+ type EventTrigger t :: * -> *
29+ type EventHandle t :: * -> *
30+ type HostFrame t :: * -> *
31+
32+-- | Monad in which Events can be 'subscribed'. This forces all underlying event sources to be initialized, so that the event will fire whenever it ought to. Events must be subscribed before they are read using readEvent
33+class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where
34+ -- | Subscribe to an event and set it up if needed.
35+ --
36+ -- This function will create a new 'EventHandle' from an 'Event'. This handle may then be used via
37+ -- 'readEvent' in the read callback of 'fireEventsAndRead'.
38+ --
39+ -- If the event wasn't subscribed to before (either manually or through a dependent event or behavior)
40+ -- then this function will cause the event and all dependencies of this event to be set up.
41+ -- For example, if the event was created by 'newEventWithTrigger', then it's callback will be executed.
42+ --
43+ -- It's safe to call this function multiple times.
44+ subscribeEvent :: Event t a -> m (EventHandle t a)
45+
46+-- | Monad that allows to read events' values.
47+class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where
48+ -- | Read the value of an 'Event' from an 'EventHandle' (created by calling 'subscribeEvent').
49+ --
50+ -- After event propagation is done, all events can be in two states: either they are firing with some value or they are not firing.
51+ -- In the former case, this function returns @Just act@, where @act@ in an action to read the current value of
52+ -- the event. In the latter case, the function returns @Nothing@.
53+ --
54+ -- This function is normally used in the calllback for 'fireEventsAndRead'.
55+ readEvent :: EventHandle t a -> m (Maybe (m a))
56+
57+-- | A monad where new events feed from external sources can be created.
58+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where
59+ -- | Creates a root 'Event' (one that is not based on any other event).
60+ --
61+ -- When a subscriber first subscribes to an event (building another event
62+ -- that depends on the subscription) the given callback function is run and
63+ -- passed a trigger. The callback function can then set up the event source in IO.
64+ -- After this is done, the callback function must return an accompanying teardown action.
65+ --
66+ -- Any time between setup and teardown the trigger can be used to fire
67+ -- the event, by passing it to 'fireEventsAndRead'.
68+ --
69+ -- Note: An event may be set up multiple times. So after the teardown action is executed, the event may still be set up again in the future.
70+ newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
71+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)
72+
73+class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, MonadReadEvent t (ReadPhase m), MonadSample t (ReadPhase m), MonadHold t (ReadPhase m)) => MonadReflexHost t m | m -> t where
74+ type ReadPhase m :: * -> *
75+ -- | Propagate some events firings and read the values of events afterwards.
76+ --
77+ -- This function will create a new frame to fire the given events. It will then update all
78+ -- dependent events and behaviors. After that is done, the given callback is executed which
79+ -- allows to read the final values of events and check whether they have fired in this frame or
80+ -- not.
81+ --
82+ -- All events that are given are fired at the same time.
83+ --
84+ -- This function is typically used in the main loop of a reflex framework implementation.
85+ -- The main loop waits for external events to happen (such as keyboard input or a mouse click)
86+ -- and then fires the corresponding events using this function. The read callback can be used
87+ -- to read output events and perform a corresponding response action to the external event.
88+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m a
89+
90+ -- | Run a frame without any events firing.
91+ --
92+ -- This function should be used when you want to use 'sample' and 'hold' when no events are currently firing.
93+ -- Using this function in that case can improve performance, since the implementation can assume that no events
94+ -- are firing when 'sample' or 'hold' are called.
95+ --
96+ -- This function is commonly used to set up the basic event network when the application starts up.
97+ runHostFrame :: HostFrame t a -> m a
98+
99+-- | Like 'fireEventsAndRead', but without reading any events.
100+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()
101+fireEvents dm = fireEventsAndRead dm $ return ()
102+{-# INLINE fireEvents #-}
103+
104+-- | Create a new event and store its trigger in an 'IORef' while it's active.
105+--
106+-- An event is only active between the set up (when it's first subscribed to) and the teardown phases (when noboby is subscribing the event anymore).
107+-- This function returns an Event and an 'IORef'. As long as the event is active, the 'IORef' will contain 'Just' the event trigger to
108+-- trigger this event. When the event is not active, the 'IORef' will contain 'Nothing'. This allows event sources to be more efficient,
109+-- since they don't need to produce events when nobody is listening.
110+newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))
111+newEventWithTriggerRef = do
112+ rt <- newRef Nothing
113+ e <- newEventWithTrigger $ \t -> do
114+ writeRef rt $ Just t
115+ return $ writeRef rt Nothing
116+ return (e, rt)
117+{-# INLINE newEventWithTriggerRef #-}
118+
119+fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
120+fireEventRef mtRef input = do
121+ mt <- readRef mtRef
122+ case mt of
123+ Nothing -> return ()
124+ Just trigger -> fireEvents [trigger :=> Identity input]
125+
126+fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)
127+fireEventRefAndRead mtRef input e = do
128+ mt <- readRef mtRef
129+ case mt of
130+ Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire
131+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do
132+ mGetValue <- readEvent e
133+ case mGetValue of
134+ Nothing -> return Nothing
135+ Just getValue -> liftM Just getValue
136+
137+
138+--------------------------------------------------------------------------------
139+-- Instances
140+--------------------------------------------------------------------------------
141+
142+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where
143+ newEventWithTrigger = lift . newEventWithTrigger
144+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
145+
146+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where
147+ subscribeEvent = lift . subscribeEvent
148+
149+instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where
150+ type ReadPhase (ReaderT r m) = ReadPhase m
151+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
152+ runHostFrame = lift . runHostFrame
153+
154+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where
155+ newEventWithTrigger = lift . newEventWithTrigger
156+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
157+
158+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where
159+ subscribeEvent = lift . subscribeEvent
160+
161+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where
162+ type ReadPhase (WriterT w m) = ReadPhase m
163+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
164+ runHostFrame = lift . runHostFrame
165+
166+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where
167+ newEventWithTrigger = lift . newEventWithTrigger
168+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
169+
170+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where
171+ subscribeEvent = lift . subscribeEvent
172+
173+instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where
174+ type ReadPhase (StateT s m) = ReadPhase m
175+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
176+ runHostFrame = lift . runHostFrame
177+
178+
179+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where
180+ newEventWithTrigger = lift . newEventWithTrigger
181+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
182+
183+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (Strict.StateT r m) where
184+ subscribeEvent = lift . subscribeEvent
185+
186+instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where
187+ type ReadPhase (Strict.StateT s m) = ReadPhase m
188+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
189+ runHostFrame = lift . runHostFrame
190+
191+
192+
193+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where
194+ newEventWithTrigger = lift . newEventWithTrigger
195+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
196+
197+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where
198+ subscribeEvent = lift . subscribeEvent
199+
200+instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where
201+ type ReadPhase (ContT r m) = ReadPhase m
202+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
203+ runHostFrame = lift . runHostFrame
204+
205+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where
206+ newEventWithTrigger = lift . newEventWithTrigger
207+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
208+
209+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where
210+ subscribeEvent = lift . subscribeEvent
211+
212+instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where
213+ type ReadPhase (ExceptT e m) = ReadPhase m
214+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
215+ runHostFrame = lift . runHostFrame
216+
217+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where
218+ newEventWithTrigger = lift . newEventWithTrigger
219+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
220+
221+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where
222+ subscribeEvent = lift . subscribeEvent
223+
224+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where
225+ type ReadPhase (RWST r w s m) = ReadPhase m
226+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
227+ runHostFrame = lift . runHostFrame
src/Reflex/Spider.hsnew file+5
@@ -0,0 +1,5 @@
1+module Reflex.Spider ( Spider
2+ , SpiderHost (..) --Temporary, until Widget no longer uses unsafePerformIO
3+ ) where
4+
5+import Reflex.Spider.Internal
src/Reflex/Spider/Internal.hsnew file+1443
@@ -0,0 +1,1443 @@
1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}
2+module Reflex.Spider.Internal where
3+
4+import qualified Reflex.Class as R
5+import qualified Reflex.Host.Class as R
6+
7+import Data.IORef
8+import System.Mem.Weak
9+import Data.Foldable
10+import Data.Traversable
11+import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
12+import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
13+import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
14+import GHC.Exts
15+import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
16+import Data.Dependent.Map (DMap, DSum (..))
17+import qualified Data.Dependent.Map as DMap
18+import Data.GADT.Compare
19+import Data.Maybe
20+import Data.IntMap (IntMap)
21+import qualified Data.IntMap as IntMap
22+import Control.Monad.Ref
23+import Control.Monad.Exception
24+import Data.Monoid ((<>))
25+import Data.Coerce
26+
27+import System.IO.Unsafe
28+import Unsafe.Coerce
29+import Control.Monad.Primitive
30+
31+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
32+import Prelude hiding (mapM, mapM_, any, sequence, concat)
33+
34+debugPropagate :: Bool
35+
36+debugInvalidateHeight :: Bool
37+
38+#ifdef DEBUG
39+
40+#define DEBUG_NODEIDS
41+
42+debugPropagate = True
43+
44+debugInvalidateHeight = True
45+
46+class HasNodeId a where
47+ getNodeId :: a -> Int
48+
49+instance HasNodeId (Hold a) where
50+ getNodeId = holdNodeId
51+
52+instance HasNodeId (PushSubscribed a b) where
53+ getNodeId = pushSubscribedNodeId
54+
55+instance HasNodeId (SwitchSubscribed a) where
56+ getNodeId = switchSubscribedNodeId
57+
58+instance HasNodeId (MergeSubscribed a) where
59+ getNodeId = mergeSubscribedNodeId
60+
61+instance HasNodeId (FanSubscribed a) where
62+ getNodeId = fanSubscribedNodeId
63+
64+instance HasNodeId (CoincidenceSubscribed a) where
65+ getNodeId = coincidenceSubscribedNodeId
66+
67+instance HasNodeId (RootSubscribed a) where
68+ getNodeId = rootSubscribedNodeId
69+
70+showNodeId :: HasNodeId a => a -> String
71+showNodeId = ("#"<>) . show . getNodeId
72+
73+#else
74+
75+debugPropagate = False
76+
77+debugInvalidateHeight = False
78+
79+showNodeId :: a -> String
80+showNodeId = const ""
81+
82+#endif
83+
84+#ifdef DEBUG_NODEIDS
85+{-# NOINLINE nextNodeIdRef #-}
86+nextNodeIdRef :: IORef Int
87+nextNodeIdRef = unsafePerformIO $ newIORef 1
88+
89+{-# NOINLINE unsafeNodeId #-}
90+unsafeNodeId :: a -> Int
91+unsafeNodeId a = unsafePerformIO $ do
92+ touch a
93+ atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
94+#endif
95+
96+--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
97+--type role Hold representational
98+data Hold a
99+ = Hold { holdValue :: !(IORef a)
100+ , holdInvalidators :: !(IORef [Weak Invalidator])
101+ -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce'
102+ , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef
103+ , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef
104+#ifdef DEBUG_NODEIDS
105+ , holdNodeId :: Int
106+#endif
107+ }
108+
109+data EventEnv
110+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])
111+ , eventEnvHoldInits :: !(IORef [SomeHoldInit])
112+ , eventEnvClears :: !(IORef [SomeMaybeIORef])
113+ , eventEnvRootClears :: !(IORef [SomeDMapIORef])
114+ , eventEnvCurrentHeight :: !(IORef Int)
115+ , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])
116+ , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
117+ }
118+
119+runEventM :: EventM a -> EventEnv -> IO a
120+runEventM = runReaderT . unEventM
121+
122+askToAssignRef :: EventM (IORef [SomeAssignment])
123+askToAssignRef = EventM $ asks eventEnvAssignments
124+
125+askHoldInitRef :: EventM (IORef [SomeHoldInit])
126+askHoldInitRef = EventM $ asks eventEnvHoldInits
127+
128+getCurrentHeight :: EventM Int
129+getCurrentHeight = EventM $ do
130+ heightRef <- asks eventEnvCurrentHeight
131+ liftIO $ readIORef heightRef
132+
133+putCurrentHeight :: Int -> EventM ()
134+putCurrentHeight h = EventM $ do
135+ heightRef <- asks eventEnvCurrentHeight
136+ liftIO $ writeIORef heightRef h
137+
138+scheduleClear :: IORef (Maybe a) -> EventM ()
139+scheduleClear r = EventM $ do
140+ clears <- asks eventEnvClears
141+ liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
142+
143+scheduleRootClear :: IORef (DMap k Identity) -> EventM ()
144+scheduleRootClear r = EventM $ do
145+ clears <- asks eventEnvRootClears
146+ liftIO $ modifyIORef' clears (SomeDMapIORef r :)
147+
148+scheduleMerge :: Int -> MergeSubscribed a -> EventM ()
149+scheduleMerge height subscribed = EventM $ do
150+ delayedRef <- asks eventEnvDelayedMerges
151+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed]
152+
153+emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()
154+emitCoincidenceInfo sci = EventM $ do
155+ ciRef <- asks eventEnvCoincidenceInfos
156+ liftIO $ modifyIORef' ciRef (sci:)
157+
158+-- Note: hold cannot examine its event until after the phase is over
159+hold :: a -> Event a -> EventM (Behavior a)
160+hold v0 e = do
161+ holdInitRef <- askHoldInitRef
162+ liftIO $ do
163+ valRef <- newIORef v0
164+ invsRef <- newIORef []
165+ parentRef <- newIORef $ error "hold not yet initialized (parent)"
166+ subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)"
167+ let h = Hold
168+ { holdValue = valRef
169+ , holdInvalidators = invsRef
170+ , holdSubscriber = subscriberRef
171+ , holdParent = parentRef
172+#ifdef DEBUG_NODEIDS
173+ , holdNodeId = unsafeNodeId (v0, e)
174+#endif
175+ }
176+ s <- newSubscriberHold h
177+ writeIORef subscriberRef $ unsafeCoerce s
178+ modifyIORef' holdInitRef (SomeHoldInit e h :)
179+ return $ BehaviorHold h
180+
181+subscribeHold :: Event a -> Hold a -> EventM ()
182+subscribeHold e h = do
183+ toAssignRef <- askToAssignRef
184+ !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item
185+ ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber"
186+ subd <- subscribe e $ WeakSubscriberSimple ws
187+ liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd
188+ occ <- liftIO $ getEventSubscribedOcc subd
189+ case occ of
190+ Nothing -> return ()
191+ Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)
192+
193+--type role BehaviorM representational
194+-- BehaviorM can sample behaviors
195+newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
196+
197+data BehaviorSubscribed a
198+ = BehaviorSubscribedHold (Hold a)
199+ | BehaviorSubscribedPull (PullSubscribed a)
200+
201+data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
202+
203+--type role PullSubscribed representational
204+data PullSubscribed a
205+ = PullSubscribed { pullSubscribedValue :: !a
206+ , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])
207+ , pullSubscribedOwnInvalidator :: !Invalidator
208+ , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
209+ }
210+
211+--type role Pull representational
212+data Pull a
213+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
214+ , pullCompute :: !(BehaviorM a)
215+ }
216+
217+data Invalidator
218+ = forall a. InvalidatorPull (Pull a)
219+ | forall a. InvalidatorSwitch (SwitchSubscribed a)
220+
221+data RootSubscribed a
222+ = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
223+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
224+ }
225+
226+data Root (k :: * -> *)
227+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
228+ , rootSubscribed :: !(IORef (DMap k RootSubscribed))
229+ , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
230+ }
231+
232+data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
233+
234+-- EventM can do everything BehaviorM can, plus create holds
235+newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, 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
236+
237+data PushSubscribed a b
238+ = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)
239+ , pushSubscribedHeight :: !(IORef Int)
240+ , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b])
241+ , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die
242+ , pushSubscribedParent :: !(EventSubscribed a)
243+#ifdef DEBUG_NODEIDS
244+ , pushSubscribedNodeId :: Int
245+#endif
246+ }
247+
248+data Push a b
249+ = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed
250+ , pushParent :: !(Event a)
251+ , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
252+ }
253+
254+data MergeSubscribed k
255+ = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
256+ , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
257+ , mergeSubscribedHeight :: !(IORef Int)
258+ , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])
259+ , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory
260+ , mergeSubscribedParents :: !(DMap k EventSubscribed)
261+#ifdef DEBUG_NODEIDS
262+ , mergeSubscribedNodeId :: Int
263+#endif
264+ }
265+
266+--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
267+data Merge k
268+ = Merge { mergeParents :: !(DMap k Event)
269+ , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?
270+ }
271+
272+data FanSubscriberKey k a where
273+ FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]
274+
275+instance GEq k => GEq (FanSubscriberKey k) where
276+ geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of
277+ Nothing -> Nothing
278+ Just Refl -> Just Refl
279+
280+instance GCompare k => GCompare (FanSubscriberKey k) where
281+ gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of
282+ GLT -> GLT
283+ GEQ -> GEQ
284+ GGT -> GGT
285+
286+data FanSubscribed k
287+ = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))
288+ , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))
289+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))
290+#ifdef DEBUG_NODEIDS
291+ , fanSubscribedNodeId :: Int
292+#endif
293+ }
294+
295+data Fan k
296+ = Fan { fanParent :: !(Event (DMap k Identity))
297+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))
298+ }
299+
300+data SwitchSubscribed a
301+ = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
302+ , switchSubscribedHeight :: !(IORef Int)
303+ , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
304+ , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)
305+ , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
306+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator
307+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
308+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
309+ , switchSubscribedParent :: !(Behavior (Event a))
310+ , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))
311+#ifdef DEBUG_NODEIDS
312+ , switchSubscribedNodeId :: Int
313+#endif
314+ }
315+
316+data Switch a
317+ = Switch { switchParent :: !(Behavior (Event a))
318+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
319+ }
320+
321+data CoincidenceSubscribed a
322+ = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
323+ , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
324+ , coincidenceSubscribedHeight :: !(IORef Int)
325+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
326+ , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
327+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
328+#ifdef DEBUG_NODEIDS
329+ , coincidenceSubscribedNodeId :: Int
330+#endif
331+ }
332+
333+data Coincidence a
334+ = Coincidence { coincidenceParent :: !(Event (Event a))
335+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
336+ }
337+
338+data Box a = Box { unBox :: a }
339+
340+--type WeakSubscriber a = Weak (Subscriber a)
341+data WeakSubscriber a
342+ = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare?
343+ | WeakSubscriberSimple !(Weak (Subscriber a))
344+
345+showWeakSubscriberType :: WeakSubscriber a -> String
346+showWeakSubscriberType = \case
347+ WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"
348+ WeakSubscriberSimple _ -> "WeakSubscriberSimple"
349+
350+deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a))
351+deRefWeakSubscriber ws = case ws of
352+ WeakSubscriberSimple w -> deRefWeak w
353+ WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w
354+
355+data Subscriber a
356+ = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)
357+ | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
358+ | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
359+ | SubscriberHold !(Hold a)
360+ | SubscriberSwitch (SwitchSubscribed a)
361+ | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
362+ | SubscriberCoincidenceInner (CoincidenceSubscribed a)
363+
364+showSubscriberType :: Subscriber a -> String
365+showSubscriberType = \case
366+ SubscriberPush _ _ -> "SubscriberPush"
367+ SubscriberMerge _ _ -> "SubscriberMerge"
368+ SubscriberFan _ -> "SubscriberFan"
369+ SubscriberHold _ -> "SubscriberHold"
370+ SubscriberSwitch _ -> "SubscriberSwitch"
371+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
372+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
373+
374+data Event a
375+ = forall k. GCompare k => EventRoot !(k a) !(Root k)
376+ | EventNever
377+ | forall b. EventPush !(Push b a)
378+ | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
379+ | forall k. GCompare k => EventFan !(k a) !(Fan k)
380+ | EventSwitch !(Switch a)
381+ | EventCoincidence !(Coincidence a)
382+
383+showEventType :: Event a -> String
384+showEventType = \case
385+ EventRoot _ _ -> "EventRoot"
386+ EventNever -> "EventNever"
387+ EventPush _ -> "EventPush"
388+ EventMerge _ -> "EventMerge"
389+ EventFan _ _ -> "EventFan"
390+ EventSwitch _ -> "EventSwitch"
391+ EventCoincidence _ -> "EventCoincidence"
392+
393+data EventSubscribed a
394+ = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
395+ | EventSubscribedNever
396+ | forall b. EventSubscribedPush !(PushSubscribed b a)
397+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
398+ | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
399+ | EventSubscribedSwitch !(SwitchSubscribed a)
400+ | EventSubscribedCoincidence !(CoincidenceSubscribed a)
401+
402+-- These function are constructor functions that are marked NOINLINE so they are
403+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
404+-- so any weak references that are attached to the constructors will have their
405+-- finalizer run. Using the opaque constructor, does not see the
406+-- constructor application, so it behaves like an IORef and cannot be fused away.
407+--
408+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
409+-- the weak pointer to it in some cases.
410+
411+{-# NOINLINE newRootSubscribed #-}
412+newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
413+newRootSubscribed occ subs =
414+ return $! RootSubscribed
415+ { rootSubscribedOccurrence = occ
416+ , rootSubscribedSubscribers = subs
417+ }
418+
419+{-# NOINLINE newSubscriberPush #-}
420+newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
421+newSubscriberPush compute subd = return $! SubscriberPush compute subd
422+
423+{-# NOINLINE newSubscriberHold #-}
424+newSubscriberHold :: Hold a -> IO (Subscriber a)
425+newSubscriberHold h = return $! SubscriberHold h
426+
427+{-# NOINLINE newSubscriberFan #-}
428+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
429+newSubscriberFan subd = return $! SubscriberFan subd
430+
431+{-# NOINLINE newSubscriberSwitch #-}
432+newSubscriberSwitch :: SwitchSubscribed a -> IO (Subscriber a)
433+newSubscriberSwitch subd = return $! SubscriberSwitch subd
434+
435+{-# NOINLINE newSubscriberCoincidenceOuter #-}
436+newSubscriberCoincidenceOuter :: CoincidenceSubscribed b -> IO (Subscriber (Event b))
437+newSubscriberCoincidenceOuter subd = return $! SubscriberCoincidenceOuter subd
438+
439+{-# NOINLINE newSubscriberCoincidenceInner #-}
440+newSubscriberCoincidenceInner :: CoincidenceSubscribed a -> IO (Subscriber a)
441+newSubscriberCoincidenceInner subd = return $! SubscriberCoincidenceInner subd
442+
443+{-# NOINLINE newInvalidatorSwitch #-}
444+newInvalidatorSwitch :: SwitchSubscribed a -> IO Invalidator
445+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
446+
447+{-# NOINLINE newInvalidatorPull #-}
448+newInvalidatorPull :: Pull a -> IO Invalidator
449+newInvalidatorPull p = return $! InvalidatorPull p
450+
451+{-# NOINLINE newBox #-}
452+newBox :: a -> IO (Box a)
453+newBox a = return $! Box a
454+
455+--type role Behavior representational
456+data Behavior a
457+ = BehaviorHold !(Hold a)
458+ | BehaviorConst !a
459+ | BehaviorPull !(Pull a)
460+
461+-- ResultM can read behaviors and events
462+type ResultM = EventM
463+
464+{-# NOINLINE unsafeNewIORef #-}
465+unsafeNewIORef :: a -> b -> IORef b
466+unsafeNewIORef _ b = unsafePerformIO $ newIORef b
467+
468+instance Functor Event where
469+ fmap f = push $ return . Just . f
470+
471+instance Functor Behavior where
472+ fmap f = pull . liftM f . readBehaviorTracked
473+
474+{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
475+push :: (a -> EventM (Maybe b)) -> Event a -> Event b
476+push f e = EventPush $ Push
477+ { pushCompute = f
478+ , pushParent = e
479+ , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
480+ }
481+{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
482+
483+{-# NOINLINE pull #-}
484+pull :: BehaviorM a -> Behavior a
485+pull a = BehaviorPull $ Pull
486+ { pullCompute = a
487+ , pullValue = unsafeNewIORef a Nothing
488+ }
489+{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}
490+
491+{-# NOINLINE switch #-}
492+switch :: Behavior (Event a) -> Event a
493+switch a = EventSwitch $ Switch
494+ { switchParent = a
495+ , switchSubscribed = unsafeNewIORef a Nothing
496+ }
497+{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}
498+
499+coincidence :: Event (Event a) -> Event a
500+coincidence a = EventCoincidence $ Coincidence
501+ { coincidenceParent = a
502+ , coincidenceSubscribed = unsafeNewIORef a Nothing
503+ }
504+
505+newRoot :: IO (Root k)
506+newRoot = do
507+ occRef <- newIORef DMap.empty
508+ subscribedRef <- newIORef DMap.empty
509+ return $ Root
510+ { rootOccurrence = occRef
511+ , rootSubscribed = subscribedRef
512+ , rootInit = \_ _ -> return $ return ()
513+ }
514+
515+propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()
516+propagateAndUpdateSubscribersRef subscribersRef a = do
517+ subscribers <- liftIO $ readIORef subscribersRef
518+ liftIO $ writeIORef subscribersRef []
519+ stillAlive <- propagate a subscribers
520+ liftIO $ modifyIORef' subscribersRef (++stillAlive)
521+
522+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
523+run :: [DSum RootTrigger Identity] -> ResultM b -> IO b
524+run roots after = do
525+ when debugPropagate $ putStrLn "Running an event frame"
526+ result <- runFrame $ do
527+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
528+ occBefore <- liftIO $ do
529+ occBefore <- readIORef occRef
530+ writeIORef occRef $ DMap.insert k a occBefore
531+ return occBefore
532+ if DMap.null occBefore
533+ then do scheduleRootClear occRef
534+ return $ Just r
535+ else return Nothing
536+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
537+ propagateAndUpdateSubscribersRef subscribersRef a
538+ delayedRef <- EventM $ asks eventEnvDelayedMerges
539+ let go = do
540+ delayed <- liftIO $ readIORef delayedRef
541+ case IntMap.minViewWithKey delayed of
542+ Nothing -> return ()
543+ Just ((currentHeight, current), future) -> do
544+ when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight
545+ putCurrentHeight currentHeight
546+ liftIO $ writeIORef delayedRef future
547+ forM_ current $ \d -> case d of
548+ DelayedMerge subscribed -> do
549+ height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
550+ case height `compare` currentHeight of
551+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
552+ GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
553+ EQ -> do
554+ m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
555+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty
556+ --TODO: Assert that m is not empty
557+ liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m
558+ scheduleClear $ mergeSubscribedOccurrence subscribed
559+ propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m
560+ go
561+ go
562+ putCurrentHeight maxBound
563+ after
564+ when debugPropagate $ putStrLn "Done running an event frame"
565+ return result
566+
567+data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
568+
569+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))
570+
571+data SomeAssignment = forall a. SomeAssignment (Hold a) a
572+
573+data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
574+
575+debugFinalize :: Bool
576+debugFinalize = False
577+
578+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
579+mkWeakPtrWithDebug x debugNote = mkWeakPtr x $
580+ if debugFinalize
581+ then Just $ putStrLn $ "finalizing: " ++ debugNote
582+ else Nothing
583+
584+type WeakList a = [Weak a]
585+
586+--TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?
587+traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]
588+traverseAndCleanWeakList_ deRef ws f = go ws
589+ where go [] = return []
590+ go (h:t) = do
591+ ma <- deRef h
592+ case ma of
593+ Just a -> do
594+ f a
595+ t' <- go t
596+ return $ h : t'
597+ Nothing -> go t
598+
599+-- | Propagate everything at the current height
600+propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]
601+propagate a subscribers = do
602+ traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of
603+ SubscriberPush compute subscribed -> do
604+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed
605+ occ <- compute a
606+ case occ of
607+ Nothing -> return () -- No need to write a Nothing back into the Ref
608+ Just o -> do
609+ liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
610+ scheduleClear $ pushSubscribedOccurrence subscribed
611+ liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))
612+ SubscriberMerge k subscribed -> do
613+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed
614+ oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
615+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM
616+ when (DMap.null oldM) $ do -- Only schedule the firing once
617+ height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
618+ --TODO: assertions about height
619+ currentHeight <- getCurrentHeight
620+ when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"
621+ scheduleMerge height subscribed
622+ SubscriberFan subscribed -> do
623+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
624+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
625+ --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
626+ forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of
627+ Nothing -> do
628+ when debugPropagate $ liftIO $ putStrLn "No subscriber for key"
629+ return ()
630+ Just (Identity subsubs) -> do
631+ _ <- propagate v subsubs --TODO: use the value of this
632+ return ()
633+ --TODO: The following is way too slow to do all the time
634+ subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do
635+ subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())
636+ return $ if null subsubs'
637+ then Nothing
638+ else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))
639+ liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'
640+ SubscriberHold h -> do
641+ invalidators <- liftIO $ readIORef $ holdInvalidators h
642+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
643+ toAssignRef <- askToAssignRef
644+ liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)
645+ SubscriberSwitch subscribed -> do
646+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed
647+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
648+ scheduleClear $ switchSubscribedOccurrence subscribed
649+ subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed
650+ liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs
651+ SubscriberCoincidenceOuter subscribed -> do
652+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
653+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
654+ when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight
655+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
656+ when debugPropagate $ liftIO $ putStrLn $ " isJust occ = " <> show (isJust occ)
657+ when debugPropagate $ liftIO $ putStrLn $ " innerHeight = " <> show innerHeight
658+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
659+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
660+ case occ of
661+ Nothing -> do
662+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
663+ writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
664+ mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
665+ mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
666+ Just o -> do -- Since it's already firing, no need to adjust height
667+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
668+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
669+ liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
670+ SubscriberCoincidenceInner subscribed -> do
671+ when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed
672+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
673+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
674+ liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
675+
676+data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
677+
678+subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
679+subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
680+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
681+ wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
682+ innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
683+ innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
684+ innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
685+ let height = max innerHeight outerHeight
686+ emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing
687+ return (innerOcc, height, innerSubd)
688+
689+readBehavior :: Behavior a -> IO a
690+readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
691+
692+runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a
693+runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi
694+
695+askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
696+askInvalidator = liftM (fmap fst) $ BehaviorM ask
697+
698+askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
699+askParentsRef = liftM (fmap snd) $ BehaviorM ask
700+
701+readBehaviorTracked :: Behavior a -> BehaviorM a
702+readBehaviorTracked b = case b of
703+ BehaviorHold h -> do
704+ result <- liftIO $ readIORef $ holdValue h
705+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
706+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
707+ liftIO $ touch $ holdSubscriber h
708+ return result
709+ BehaviorConst a -> return a
710+ BehaviorPull p -> do
711+ val <- liftIO $ readIORef $ pullValue p
712+ case val of
713+ Just subscribed -> do
714+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
715+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
716+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
717+ return $ pullSubscribedValue subscribed
718+ Nothing -> do
719+ i <- liftIO $ newInvalidatorPull p
720+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
721+ parentsRef <- liftIO $ newIORef []
722+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
723+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
724+ parents <- liftIO $ readIORef parentsRef
725+ let subscribed = PullSubscribed
726+ { pullSubscribedValue = a
727+ , pullSubscribedInvalidators = invsRef
728+ , pullSubscribedOwnInvalidator = i
729+ , pullSubscribedParents = parents
730+ }
731+ liftIO $ writeIORef (pullValue p) $ Just subscribed
732+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
733+ return a
734+
735+readEvent :: Event a -> ResultM (Maybe a)
736+readEvent e = case e of
737+ EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
738+ EventNever -> return Nothing
739+ EventPush p -> do
740+ subscribed <- getPushSubscribed p
741+ liftIO $ do
742+ result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
743+ touch $ pushSubscribedSelf subscribed
744+ return result
745+ EventMerge m -> do
746+ subscribed <- getMergeSubscribed m
747+ liftIO $ do
748+ result <- readIORef $ mergeSubscribedOccurrence subscribed
749+ touch $ mergeSubscribedSelf subscribed
750+ return result
751+ EventFan k f -> do
752+ parentOcc <- readEvent $ fanParent f
753+ return . coerce $ DMap.lookup k =<< parentOcc
754+ EventSwitch s -> do
755+ subscribed <- getSwitchSubscribed s
756+ liftIO $ do
757+ result <- readIORef $ switchSubscribedOccurrence subscribed
758+ touch $ switchSubscribedSelf subscribed
759+ touch $ switchSubscribedOwnInvalidator subscribed
760+ return result
761+ EventCoincidence c -> do
762+ subscribed <- getCoincidenceSubscribed c
763+ liftIO $ do
764+ result <- readIORef $ coincidenceSubscribedOccurrence subscribed
765+ touch $ coincidenceSubscribedOuter subscribed
766+ --TODO: do we need to touch the inner subscriber?
767+ return result
768+
769+-- Always refers to 0
770+{-# NOINLINE zeroRef #-}
771+zeroRef :: IORef Int
772+zeroRef = unsafePerformIO $ newIORef 0
773+
774+getEventSubscribed :: Event a -> EventM (EventSubscribed a)
775+getEventSubscribed e = case e of
776+ EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r
777+ EventNever -> return EventSubscribedNever
778+ EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
779+ EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
780+ EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m
781+ EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s
782+ EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c
783+
784+debugSubscribe :: Bool
785+debugSubscribe = False
786+
787+subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()
788+subscribeEventSubscribed es ws = case es of
789+ EventSubscribedRoot r -> do
790+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"
791+ modifyIORef' (rootSubscribedSubscribers r) (ws:)
792+ EventSubscribedNever -> do
793+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"
794+ return ()
795+ EventSubscribedPush subscribed -> do
796+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"
797+ modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)
798+ EventSubscribedFan k subscribed -> do
799+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"
800+ modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws])
801+ EventSubscribedMerge subscribed -> do
802+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"
803+ modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)
804+ EventSubscribedSwitch subscribed -> do
805+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"
806+ modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)
807+ EventSubscribedCoincidence subscribed -> do
808+ when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"
809+ modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)
810+
811+getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
812+getEventSubscribedOcc es = case es of
813+ EventSubscribedRoot r -> rootSubscribedOccurrence r
814+ EventSubscribedNever -> return Nothing
815+ EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
816+ EventSubscribedFan k subscribed -> do
817+ parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed
818+ let occ = coerce $ DMap.lookup k =<< parentOcc
819+ return occ
820+ EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed
821+ EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed
822+ EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed
823+
824+eventSubscribedHeightRef :: EventSubscribed a -> IORef Int
825+eventSubscribedHeightRef es = case es of
826+ EventSubscribedRoot _ -> zeroRef
827+ EventSubscribedNever -> zeroRef
828+ EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
829+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed
830+ EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
831+ EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
832+ EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
833+
834+subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)
835+subscribe e ws = do
836+ subd <- getEventSubscribed e
837+ liftIO $ subscribeEventSubscribed subd ws
838+ return subd
839+
840+noinlineFalse :: Bool
841+noinlineFalse = False
842+{-# NOINLINE noinlineFalse #-}
843+
844+getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
845+getRootSubscribed k r = do
846+ mSubscribed <- liftIO $ readIORef $ rootSubscribed r
847+ case DMap.lookup k mSubscribed of
848+ Just subscribed -> return subscribed
849+ Nothing -> liftIO $ do
850+ subscribersRef <- newIORef []
851+ subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
852+ -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
853+ uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
854+ addFinalizer subscribed $ do
855+ when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
856+-- putStrLn "Uninit root"
857+ uninit
858+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed
859+ return subscribed
860+
861+-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
862+getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)
863+getPushSubscribed p = do
864+ mSubscribed <- liftIO $ readIORef $ pushSubscribed p
865+ case mSubscribed of
866+ Just subscribed -> return subscribed
867+ Nothing -> do -- Not yet subscribed
868+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
869+ s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
870+ ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
871+ subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
872+ parentOcc <- liftIO $ getEventSubscribedOcc subd
873+ occ <- liftM join $ mapM (pushCompute p) parentOcc
874+ occRef <- liftIO $ newIORef occ
875+ when (isJust occ) $ scheduleClear occRef
876+ subscribersRef <- liftIO $ newIORef []
877+ let subscribed = PushSubscribed
878+ { pushSubscribedOccurrence = occRef
879+ , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
880+ , pushSubscribedSubscribers = subscribersRef
881+ , pushSubscribedSelf = unsafeCoerce s
882+ , pushSubscribedParent = subd
883+#ifdef DEBUG_NODEIDS
884+ , pushSubscribedNodeId = unsafeNodeId p
885+#endif
886+ }
887+ liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
888+ return subscribed
889+
890+getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)
891+getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
892+ mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
893+ case mSubscribed of
894+ Just subscribed -> return subscribed
895+ Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
896+ subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
897+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
898+ s <- liftIO $ newBox subscribedUnsafe
899+ ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
900+ subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
901+ parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
902+ parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd
903+ height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
904+ return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd)
905+ let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers
906+ subscriberHeights = map (\(_, _, x, _) -> x) subscribers
907+ myHeight =
908+ if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
909+ then invalidHeight
910+ else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here
911+ currentHeight <- getCurrentHeight
912+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
913+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
914+ else (Nothing, dm)
915+ when (not $ DMap.null accum) $ do
916+ scheduleMerge myHeight subscribedUnsafe
917+ occRef <- liftIO $ newIORef occ
918+ when (isJust occ) $ scheduleClear occRef
919+ accumRef <- liftIO $ newIORef accum
920+ heightRef <- liftIO $ newIORef myHeight
921+ subsRef <- liftIO $ newIORef []
922+ let subscribed = MergeSubscribed
923+ { mergeSubscribedOccurrence = occRef
924+ , mergeSubscribedAccum = accumRef
925+ , mergeSubscribedHeight = heightRef
926+ , mergeSubscribedSubscribers = subsRef
927+ , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?
928+ , mergeSubscribedParents = DMap.fromDistinctAscList $ map (\(_, _, _, x) -> x) subscribers
929+#ifdef DEBUG_NODEIDS
930+ , mergeSubscribedNodeId = unsafeNodeId m
931+#endif
932+ }
933+ liftIO $ writeIORef subscribedRef subscribed
934+ return subscribed
935+ where emptyMergeSubscribed = do --TODO: This should never happen
936+ occRef <- liftIO $ newIORef Nothing
937+ accumRef <- liftIO $ newIORef DMap.empty
938+ subsRef <- liftIO $ newIORef []
939+ return $ MergeSubscribed
940+ { mergeSubscribedOccurrence = occRef
941+ , mergeSubscribedAccum = accumRef
942+ , mergeSubscribedHeight = zeroRef
943+ , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak
944+ , mergeSubscribedSelf = unsafeCoerce ()
945+ , mergeSubscribedParents = DMap.empty
946+#ifdef DEBUG_NODEIDS
947+ , mergeSubscribedNodeId = -1
948+#endif
949+ }
950+
951+getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)
952+getFanSubscribed f = do
953+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
954+ case mSubscribed of
955+ Just subscribed -> return subscribed
956+ Nothing -> do
957+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
958+ sub <- liftIO $ newSubscriberFan subscribedUnsafe
959+ wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
960+ subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
961+ subscribersRef <- liftIO $ newIORef DMap.empty
962+ let subscribed = FanSubscribed
963+ { fanSubscribedParent = subd
964+ , fanSubscribedSubscribers = subscribersRef
965+ , fanSubscribedSelf = sub
966+#ifdef DEBUG_NODEIDS
967+ , fanSubscribedNodeId = unsafeNodeId f
968+#endif
969+ }
970+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
971+ return subscribed
972+
973+getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)
974+getSwitchSubscribed s = do
975+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
976+ case mSubscribed of
977+ Just subscribed -> return subscribed
978+ Nothing -> do
979+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
980+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
981+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
982+ sub <- liftIO $ newSubscriberSwitch subscribedUnsafe
983+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
984+ wiRef <- liftIO $ newIORef wi
985+ wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
986+ selfWeakRef <- liftIO $ newIORef wsub
987+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
988+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)
989+ subd <- subscribe e $ WeakSubscriberSimple wsub
990+ subdRef <- liftIO $ newIORef subd
991+ parentOcc <- liftIO $ getEventSubscribedOcc subd
992+ occRef <- liftIO $ newIORef parentOcc
993+ when (isJust parentOcc) $ scheduleClear occRef
994+ heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
995+ subscribersRef <- liftIO $ newIORef []
996+ let subscribed = SwitchSubscribed
997+ { switchSubscribedOccurrence = occRef
998+ , switchSubscribedHeight = heightRef
999+ , switchSubscribedSubscribers = subscribersRef
1000+ , switchSubscribedSelf = sub
1001+ , switchSubscribedSelfWeak = selfWeakRef
1002+ , switchSubscribedOwnInvalidator = i
1003+ , switchSubscribedOwnWeakInvalidator = wiRef
1004+ , switchSubscribedBehaviorParents = parentsRef
1005+ , switchSubscribedParent = switchParent s
1006+ , switchSubscribedCurrentParent = subdRef
1007+#ifdef DEBUG_NODEIDS
1008+ , switchSubscribedNodeId = unsafeNodeId s
1009+#endif
1010+ }
1011+ liftIO $ writeIORef subscribedRef subscribed
1012+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1013+ return subscribed
1014+
1015+getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)
1016+getCoincidenceSubscribed c = do
1017+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1018+ case mSubscribed of
1019+ Just subscribed -> return subscribed
1020+ Nothing -> do
1021+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1022+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1023+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1024+ wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
1025+ outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
1026+ outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
1027+ outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1028+ (occ, height, mInnerSubd) <- case outerOcc of
1029+ Nothing -> return (Nothing, outerHeight, Nothing)
1030+ Just o -> do
1031+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1032+ return (occ, height, Just innerSubd)
1033+ occRef <- liftIO $ newIORef occ
1034+ when (isJust occ) $ scheduleClear occRef
1035+ heightRef <- liftIO $ newIORef height
1036+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1037+ scheduleClear innerSubdRef
1038+ subscribersRef <- liftIO $ newIORef []
1039+ let subscribed = CoincidenceSubscribed
1040+ { coincidenceSubscribedOccurrence = occRef
1041+ , coincidenceSubscribedHeight = heightRef
1042+ , coincidenceSubscribedSubscribers = subscribersRef
1043+ , coincidenceSubscribedOuter = subOuter
1044+ , coincidenceSubscribedOuterParent = outerSubd
1045+ , coincidenceSubscribedInnerParent = innerSubdRef
1046+#ifdef DEBUG_NODEIDS
1047+ , coincidenceSubscribedNodeId = unsafeNodeId c
1048+#endif
1049+ }
1050+ liftIO $ writeIORef subscribedRef subscribed
1051+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1052+ return subscribed
1053+
1054+merge :: GCompare k => DMap k Event -> Event (DMap k Identity)
1055+merge m = EventMerge $ Merge
1056+ { mergeParents = m
1057+ , mergeSubscribed = unsafeNewIORef m Nothing
1058+ }
1059+
1060+newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }
1061+
1062+fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
1063+fan e =
1064+ let f = Fan
1065+ { fanParent = e
1066+ , fanSubscribed = unsafeNewIORef e Nothing
1067+ }
1068+ in EventSelector $ \k -> EventFan k f
1069+
1070+-- | Run an event action outside of a frame
1071+runFrame :: EventM a -> IO a
1072+runFrame a = do
1073+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
1074+ holdInitRef <- newIORef []
1075+ heightRef <- newIORef 0
1076+ toClearRef <- newIORef []
1077+ toClearRootRef <- newIORef []
1078+ coincidenceInfosRef <- newIORef []
1079+ delayedRef <- liftIO $ newIORef IntMap.empty
1080+ result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do
1081+ result <- a
1082+ let runHoldInits = do
1083+ holdInits <- liftIO $ readIORef holdInitRef
1084+ if null holdInits then return () else do
1085+ liftIO $ writeIORef holdInitRef []
1086+ forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h
1087+ runHoldInits
1088+ runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1089+ return result
1090+ toClear <- readIORef toClearRef
1091+ forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1092+ toClearRoot <- readIORef toClearRootRef
1093+ forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty
1094+ toAssign <- readIORef toAssignRef
1095+ toReconnectRef <- newIORef []
1096+ forM_ toAssign $ \(SomeAssignment h v) -> do
1097+ writeIORef (holdValue h) v
1098+ writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)
1099+ coincidenceInfos <- readIORef coincidenceInfosRef
1100+ forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do
1101+ touch subInner
1102+ finalize wsubInner
1103+ mapM_ invalidateCoincidenceHeight mcs
1104+ toReconnect <- readIORef toReconnectRef
1105+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1106+ wsub <- readIORef $ switchSubscribedSelfWeak subscribed
1107+ finalize wsub
1108+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1109+ finalize wi
1110+ let !i = switchSubscribedOwnInvalidator subscribed
1111+ wi' <- mkWeakPtrWithDebug i "wi'"
1112+ writeIORef (switchSubscribedBehaviorParents subscribed) []
1113+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))
1114+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1115+ let !sub = switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk
1116+ wsub' <- mkWeakPtrWithDebug sub "wsub'"
1117+ writeIORef (switchSubscribedSelfWeak subscribed) wsub'
1118+ subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --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
1119+ {-
1120+ stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
1121+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
1122+ EventRoot _ -> "EventRoot"
1123+ EventNever -> "EventNever"
1124+ _ -> "something else"
1125+ -}
1126+ writeIORef (switchSubscribedCurrentParent subscribed) subd'
1127+ parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1128+ myHeight <- readIORef $ switchSubscribedHeight subscribed
1129+ if parentHeight == myHeight then return () else do
1130+ writeIORef (switchSubscribedHeight subscribed) parentHeight
1131+ mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1132+ forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1133+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1134+ mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1135+ return result
1136+
1137+invalidHeight :: Int
1138+invalidHeight = -1000
1139+
1140+invalidateSubscriberHeight :: WeakSubscriber a -> IO ()
1141+invalidateSubscriberHeight ws = do
1142+ ms <- deRefWeakSubscriber ws
1143+ case ms of
1144+ Nothing -> return () --TODO: cleanup?
1145+ Just s -> case s of
1146+ SubscriberPush _ subscribed -> do
1147+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1148+ mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1149+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1150+ SubscriberMerge _ subscribed -> do
1151+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1152+ oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1153+ when (oldHeight /= invalidHeight) $ do
1154+ writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight
1155+ mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1156+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1157+ SubscriberFan subscribed -> do
1158+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1159+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1160+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1161+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1162+ SubscriberHold _ -> return ()
1163+ SubscriberSwitch subscribed -> do
1164+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1165+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1166+ when (oldHeight /= invalidHeight) $ do
1167+ writeIORef (switchSubscribedHeight subscribed) $ invalidHeight
1168+ mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1169+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1170+ SubscriberCoincidenceOuter subscribed -> do
1171+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1172+ invalidateCoincidenceHeight subscribed
1173+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1174+ SubscriberCoincidenceInner subscribed -> do
1175+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1176+ invalidateCoincidenceHeight subscribed
1177+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1178+
1179+invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1180+invalidateCoincidenceHeight subscribed = do
1181+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1182+ when (oldHeight /= invalidHeight) $ do
1183+ writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight
1184+ mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
1185+
1186+--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy
1187+
1188+recalculateSubscriberHeight :: WeakSubscriber a -> IO ()
1189+recalculateSubscriberHeight ws = do
1190+ ms <- deRefWeakSubscriber ws
1191+ case ms of
1192+ Nothing -> return () --TODO: cleanup?
1193+ Just s -> case s of
1194+ SubscriberPush _ subscribed -> do
1195+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1196+ mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1197+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1198+ SubscriberMerge _ subscribed -> do
1199+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1200+ oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1201+ when (oldHeight == invalidHeight) $ do
1202+ height <- calculateMergeHeight subscribed
1203+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1204+ when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated
1205+ writeIORef (mergeSubscribedHeight subscribed) height
1206+ mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1207+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1208+ SubscriberFan subscribed -> do
1209+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1210+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1211+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1212+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1213+ SubscriberHold _ -> return ()
1214+ SubscriberSwitch subscribed -> do
1215+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1216+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1217+ when (oldHeight == invalidHeight) $ do
1218+ height <- calculateSwitchHeight subscribed
1219+ when (height /= invalidHeight) $ do
1220+ writeIORef (switchSubscribedHeight subscribed) height
1221+ mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1222+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1223+ SubscriberCoincidenceOuter subscribed -> do
1224+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1225+ void $ recalculateCoincidenceHeight subscribed
1226+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1227+ SubscriberCoincidenceInner subscribed -> do
1228+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1229+ void $ recalculateCoincidenceHeight subscribed
1230+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1231+
1232+recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
1233+recalculateCoincidenceHeight subscribed = do
1234+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1235+ when (oldHeight == invalidHeight) $ do
1236+ height <- calculateCoincidenceHeight subscribed
1237+ when (height /= invalidHeight) $ do
1238+ writeIORef (coincidenceSubscribedHeight subscribed) height
1239+ mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones
1240+
1241+calculateMergeHeight :: MergeSubscribed k -> IO Int
1242+calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do
1243+ heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do
1244+ readIORef $ eventSubscribedHeightRef es
1245+ return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
1246+
1247+calculateSwitchHeight :: SwitchSubscribed a -> IO Int
1248+calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)
1249+
1250+calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int
1251+calculateCoincidenceHeight subscribed = do
1252+ outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed
1253+ innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1254+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
1255+
1256+{-
1257+recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int
1258+recalculateEventSubscribedHeight es = case es of
1259+ EventSubscribedRoot _ -> return 0
1260+ EventSubscribedNever -> return 0
1261+ EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed
1262+ EventSubscribedMerge subscribed -> do
1263+ oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1264+ if oldHeight /= invalidHeight then return oldHeight else do
1265+ height <- calculateMergeHeight subscribed
1266+ writeIORef (mergeSubscribedHeight subscribed) height
1267+ return height
1268+ EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed
1269+ EventSubscribedSwitch subscribed -> do
1270+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1271+ if oldHeight /= invalidHeight then return oldHeight else do
1272+ height <- calculateSwitchHeight subscribed
1273+ writeIORef (switchSubscribedHeight subscribed) height
1274+ return height
1275+ EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed
1276+-}
1277+
1278+data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)
1279+
1280+debugInvalidate :: Bool
1281+debugInvalidate = False
1282+
1283+invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
1284+invalidate toReconnectRef wis = do
1285+ forM_ wis $ \wi -> do
1286+ mi <- deRefWeak wi
1287+ case mi of
1288+ Nothing -> do
1289+ when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"
1290+ return () --TODO: Should we clean this up here?
1291+ Just i -> do
1292+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
1293+ case i of
1294+ InvalidatorPull p -> do
1295+ when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"
1296+ mVal <- readIORef $ pullValue p
1297+ forM_ mVal $ \val -> do
1298+ writeIORef (pullValue p) Nothing
1299+ writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
1300+ InvalidatorSwitch subscribed -> do
1301+ when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"
1302+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
1303+ 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
1304+
1305+--------------------------------------------------------------------------------
1306+-- Reflex integration
1307+--------------------------------------------------------------------------------
1308+
1309+data Spider
1310+
1311+instance R.Reflex Spider where
1312+ newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1313+ newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }
1314+ type PullM Spider = BehaviorM
1315+ type PushM Spider = EventM
1316+ {-# INLINE never #-}
1317+ {-# INLINE constant #-}
1318+ never = SpiderEvent EventNever
1319+ constant = SpiderBehavior . BehaviorConst
1320+ push f = SpiderEvent. push f . unSpiderEvent
1321+ pull = SpiderBehavior . pull
1322+ merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event)
1323+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1324+ switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior
1325+ coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent
1326+
1327+instance R.MonadSample Spider SpiderHost where
1328+ {-# INLINE sample #-}
1329+ sample = SpiderHost . readBehavior . unSpiderBehavior
1330+
1331+instance R.MonadHold Spider SpiderHost where
1332+ hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent
1333+
1334+instance R.MonadSample Spider BehaviorM where
1335+ {-# INLINE sample #-}
1336+ sample = readBehaviorTracked . unSpiderBehavior
1337+
1338+instance R.MonadSample Spider EventM where
1339+ {-# INLINE sample #-}
1340+ sample = liftIO . readBehavior . unSpiderBehavior
1341+
1342+instance R.MonadHold Spider EventM where
1343+ {-# INLINE hold #-}
1344+ hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
1345+
1346+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a)
1347+newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
1348+
1349+instance R.MonadSubscribeEvent Spider SpiderHostFrame where
1350+ subscribeEvent e = SpiderHostFrame $ do
1351+ _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1352+ return $ SpiderEventHandle (unSpiderEvent e)
1353+
1354+instance R.ReflexHost Spider where
1355+ type EventTrigger Spider = RootTrigger
1356+ type EventHandle Spider = SpiderEventHandle
1357+ type HostFrame Spider = SpiderHostFrame
1358+
1359+instance R.MonadReadEvent Spider ReadPhase where
1360+ {-# INLINE readEvent #-}
1361+ readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle
1362+
1363+instance MonadRef EventM where
1364+ type Ref EventM = Ref IO
1365+ {-# INLINE newRef #-}
1366+ {-# INLINE readRef #-}
1367+ {-# INLINE writeRef #-}
1368+ newRef = liftIO . newRef
1369+ readRef = liftIO . readRef
1370+ writeRef r a = liftIO $ writeRef r a
1371+
1372+instance MonadAtomicRef EventM where
1373+ {-# INLINE atomicModifyRef #-}
1374+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
1375+
1376+newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
1377+
1378+newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
1379+
1380+instance R.MonadSample Spider SpiderHostFrame where
1381+ sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can
1382+
1383+instance R.MonadHold Spider SpiderHostFrame where
1384+ {-# INLINE hold #-}
1385+ hold v0 e = SpiderHostFrame $ R.hold v0 e
1386+
1387+newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
1388+newEventWithTriggerIO f = do
1389+ es <- newFanEventWithTriggerIO $ \Refl -> f
1390+ return $ select es Refl
1391+
1392+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
1393+newFanEventWithTriggerIO f = do
1394+ occRef <- newIORef DMap.empty
1395+ subscribedRef <- newIORef DMap.empty
1396+ let !r = Root
1397+ { rootOccurrence = occRef
1398+ , rootSubscribed = subscribedRef
1399+ , rootInit = f
1400+ }
1401+ return $ EventSelector $ \k -> EventRoot k r
1402+
1403+instance R.MonadReflexCreateTrigger Spider SpiderHost where
1404+ newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO
1405+ newFanEventWithTrigger f = SpiderHost $ do
1406+ es <- newFanEventWithTriggerIO f
1407+ return $ R.EventSelector $ SpiderEvent . select es
1408+
1409+instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
1410+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
1411+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
1412+ es <- newFanEventWithTriggerIO f
1413+ return $ R.EventSelector $ SpiderEvent . select es
1414+
1415+instance R.MonadSubscribeEvent Spider SpiderHost where
1416+ subscribeEvent e = SpiderHost $ do
1417+ _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1418+ return $ SpiderEventHandle (unSpiderEvent e)
1419+
1420+newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)
1421+
1422+instance R.MonadReflexHost Spider SpiderHost where
1423+ type ReadPhase SpiderHost = ReadPhase
1424+ fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a
1425+ runHostFrame = SpiderHost . runFrame . runSpiderHostFrame
1426+
1427+instance MonadRef SpiderHost where
1428+ type Ref SpiderHost = Ref IO
1429+ newRef = SpiderHost . newRef
1430+ readRef = SpiderHost . readRef
1431+ writeRef r = SpiderHost . writeRef r
1432+
1433+instance MonadAtomicRef SpiderHost where
1434+ atomicModifyRef r = SpiderHost . atomicModifyRef r
1435+
1436+instance MonadRef SpiderHostFrame where
1437+ type Ref SpiderHostFrame = Ref IO
1438+ newRef = SpiderHostFrame . newRef
1439+ readRef = SpiderHostFrame . readRef
1440+ writeRef r = SpiderHostFrame . writeRef r
1441+
1442+instance MonadAtomicRef SpiderHostFrame where
1443+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
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/Reflex/Bench/Focused.hsnew file+360
@@ -0,0 +1,360 @@
1+{-# LANGUAGE RecursiveDo, ConstraintKinds, TypeSynonymInstances, BangPatterns, ScopedTypeVariables, TupleSections, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+
3+module Reflex.Bench.Focused where
4+
5+import Reflex
6+import Reflex.TestPlan
7+
8+import Control.Monad.Fix
9+import Control.Monad
10+import Control.Monad.Identity
11+import Control.Applicative
12+--import Data.Foldable
13+import Data.Traversable (traverse, for)
14+
15+import Data.Maybe
16+import Data.Map (Map)
17+import qualified Data.Map as Map
18+import qualified Data.Dependent.Map as DMap
19+
20+import Data.Functor.Misc
21+
22+import Data.Tuple
23+import Data.List
24+import Data.List.Split
25+
26+import Data.Word
27+import Data.Monoid
28+
29+
30+import Prelude hiding (sum, concat)
31+
32+
33+mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
34+mergeTree n es | length es <= n = sum' es
35+ | otherwise = mergeTree n subTrees
36+ where
37+ merges = chunksOf n es
38+ subTrees = map sum' merges
39+ sum' = fmap sum . mconcat . fmap (fmap (:[]) )
40+
41+mergeListDyn :: (Reflex t, MonadHold t m) => [Dynamic t a] -> m (Dynamic t [a])
42+mergeListDyn dyns = traverse (mapDyn pure) dyns >>= mconcatDyn
43+
44+mergeTreeDyn :: (Num a, Reflex t, MonadHold t m, MonadFix m) => Int -> [Dynamic t a] -> m (Dynamic t a)
45+mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
46+ | otherwise = traverse sumDyns merges >>= mergeTreeDyn n
47+ where
48+ merges = chunksOf n dyns
49+ sumDyns ds = mergeListDyn ds >>= mapDyn sum
50+
51+
52+
53+-- N events all firing for N frames
54+continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
55+continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
56+
57+-- Fire N events once every P frames for total N frames (interspersed evenly)
58+occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
59+occasional n period frames = traverse plan $ zipWith occs [1..] phases
60+ where
61+ phases = take (fromIntegral n) $ concat (repeat [1..period])
62+ occs i phase = (, i) <$> [1, phase+1..frames]
63+
64+
65+
66+-- Event which never fires (but isn't 'never')
67+never' :: TestPlan t m => m (Event t Word)
68+never' = plan []
69+
70+
71+-- Event which fires once on first frame
72+event :: TestPlan t m => m (Event t Word)
73+event = plan [(1, 0)]
74+
75+-- Event which fires constantly over N frames
76+events :: TestPlan t m => Word -> m (Event t Word)
77+events n = plan $ (\i -> (i, i)) <$> [1..n]
78+
79+
80+-- N events all originating from one event
81+fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
82+fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
83+
84+
85+-- Make a fan using the value in the event converting it to a singleton Map
86+-- use a fan of size n (key is the value mod n)
87+fanMerge :: Reflex t => Word -> Event t Word -> Event t Word
88+fanMerge n e = leftmost $ s <$> [0..n - 1] where
89+ s k = select f (Const2 k)
90+ f = fan (toMap <$> e)
91+ toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)
92+
93+-- Dumb version of the above using simple fmapMaybe to filter
94+fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word
95+fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where
96+ s k = flip fmapMaybe e $ \j -> if (k == j `mod` n)
97+ then Just k
98+ else Nothing
99+
100+
101+
102+-- Create an Event with a Map which is dense to size N
103+denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
104+denseMap n = plan [(1, m)] where
105+ m = Map.fromList $ zip [1..n] [1..n]
106+
107+iter :: (a -> a) -> Word -> a -> a
108+iter _ 0 a = a
109+iter f n a = iter f (n - 1) (f a)
110+
111+iterM :: Monad m => (a -> m a) -> Word -> a -> m a
112+iterM _ 0 a = return a
113+iterM f n a = iterM f (n - 1) =<< f a
114+
115+fmapChain :: (Functor f) => Word -> f Word -> f Word
116+fmapChain = iter (fmap (+1))
117+
118+mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
119+mapDynChain = iterM (mapDyn (+1))
120+
121+joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
122+joinDynChain = iterM (\d -> joinDyn <$> mapDyn (const d) d)
123+
124+combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
125+combineDynChain = iterM (\d -> combineDyn (+) d d)
126+
127+pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
128+pingPong e1 e2 = do
129+ rec
130+ d <- foldDyn (const swap) (e1, e2) e
131+ let e = switch (fst <$> current d)
132+ return e
133+
134+switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
135+switchFactors 0 e = return e
136+switchFactors i e = do
137+ b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
138+ switchFactors (i - 1) (switch b)
139+
140+
141+switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
142+switchChain = iterM (\e -> pingPong e ((+1) <$> e))
143+
144+
145+switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
146+switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))
147+
148+switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
149+switchPromptlyChain = iterM $ \e ->
150+ switchPromptlyDyn <$> holdDyn e (e <$ e)
151+
152+
153+coinChain :: Reflex t => Word -> Event t Word -> Event t Word
154+coinChain = iter $ \e -> coincidence (e <$ e)
155+
156+fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
157+fanMergeChain width = iter $ fanMerge width
158+
159+fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
160+fmapFanMergeChain width = iter $ fmapFanMerge width
161+
162+-- | Data type for a collection (a map) which is updated by providing differences
163+data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
164+
165+-- This will hopefully become a primitive (faster!)
166+switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
167+switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
168+
169+-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
170+-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)
171+
172+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))
173+switchMergeBehaviors mapChanges = pull <$> joinMap <$> holdMap mapChanges
174+ where joinMap m = traverse sample =<< sample m
175+
176+-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
177+holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
178+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes
179+
180+ where
181+ modify k Nothing items = Map.delete k items
182+ modify k (Just item) items = Map.insert k item items
183+
184+
185+-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
186+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
187+holdMap = (current <$>) . holdMapDyn
188+
189+
190+increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
191+increasingMerge xs = do
192+ e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
193+ return (UpdatedMap Map.empty e)
194+ where
195+ reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
196+
197+decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
198+decreasingMerge xs = do
199+ e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
200+ return (UpdatedMap initial e)
201+ where
202+ initial = Map.fromList $ zip [1..] xs
203+ reset = Just <$> initial
204+
205+modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
206+modifyMerge xs = do
207+ e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
208+ return (UpdatedMap initial e)
209+ where
210+ initial = Map.fromList $ zip [1..] xs
211+
212+
213+countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
214+countMany = traverse (fmap current . count)
215+
216+countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
217+countManyDyn = traverse count
218+
219+
220+-- Given a function which creates a sub-network (from a single event)
221+-- Create a plan which uses a switch to substitute it
222+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
223+switches numFrames f = do
224+ es <- events numFrames
225+ switch <$> hold never (makeEvents es)
226+
227+ where
228+ makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
229+
230+
231+
232+-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
233+-- the other, which we're only interested in time for running frames
234+subscribing :: Word -> Word -> [(String, TestCase)]
235+subscribing n frames =
236+ [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n
237+ , testSub "fanMerge" $ return . fanMerge n
238+ , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n
239+ , testSub "fmapChain" $ return . fmapChain n
240+ , testSub "switchChain" $ switchChain n
241+ , testSub "switchPromptlyChain" $ switchPromptlyChain n
242+ , testSub "switchFactors" $ switchFactors n
243+ , testSub "coincidenceChain" $ return . coinChain n
244+ ]
245+
246+ where
247+ testSub :: (Eq a, Show a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
248+ testSub name test = testE name (switches frames test)
249+
250+-- Set of benchmark to test specifically merging dynamic collections
251+-- a pattern which occurs frequently in reflex-dom collections
252+merging :: Word -> [(String, TestCase)]
253+merging n =
254+ [ testE "static events" $ mergeList <$> sparse
255+ , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
256+ , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
257+ , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
258+
259+ , testB "static behaviors" $ pull . traverse sample <$> counters
260+ , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
261+ , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
262+ , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
263+
264+
265+ -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse
266+ -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse
267+ -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse
268+ ]
269+
270+ where
271+ sparse :: TestPlan t m => m [Event t Word]
272+ sparse = fmap (fmap (+1)) <$> occasional n 8 n
273+
274+ counters :: TestPlan t m => m [Behavior t Int]
275+ counters = countMany =<< sparse
276+
277+
278+
279+fans :: Word -> [(String, TestCase)]
280+fans n =
281+ [ testE "fanMapChain" $ fanMergeChain n 10 <$> e
282+ , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e
283+
284+ , testE "fanMerge " $ fanMerge n <$> events n
285+
286+ , testE "fmapFanMerge " $ fmapFanMerge n <$> events n
287+ , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])
288+
289+ ]
290+ where
291+
292+ e :: TestPlan t m => m (Event t Word)
293+ e = events 100
294+
295+
296+
297+
298+dynamics :: Word -> [(String, TestCase)]
299+dynamics n =
300+ [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
301+ , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
302+ , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
303+ , testE "dense mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< dense
304+ , testE "sparse mergeTree" $ fmap updated $ mergeTreeDyn 8 =<< sparse
305+ , testE "mergeDyn" $ fmap updated $ mapDyn sum =<< mergeListDyn =<< sparse
306+ ] where
307+
308+ d :: TestPlan t m => m (Dynamic t Word)
309+ d = count =<< events 10
310+
311+ sparse, dense :: TestPlan t m => m [Dynamic t Int]
312+ sparse = countManyDyn =<< occasional n 8 16
313+ dense = countManyDyn =<< continuous n 2
314+
315+
316+firing :: Word -> [(String, TestCase)]
317+firing n =
318+ [ testE "fmapChain" $ fmapChain n <$> e
319+ , testE "switchChain2" $ switchChain2 n =<< e
320+ , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
321+ , testE "switchFactors" $ switchFactors n =<< e
322+ , testE "coincidenceChain" $ coinChain n <$> e
323+
324+ , testE "dense mergeTree" $ mergeTree 8 <$> dense
325+ , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
326+
327+ -- Triggers test failure in Spider
328+ --, testE "runFrame" $ events n
329+
330+ , testB "sum counters" $ do
331+ counts <- counters
332+ return $ pull $ sum <$> traverse sample counts
333+
334+ , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4)
335+ , testB "pullChain2" $ do
336+ es <- events 4
337+ e <- plan [(0, ())]
338+
339+ b <- hold (constant 0) $
340+ pushAlways (const $ fmapChain n <$> hold 0 es) e
341+
342+ return (join b)
343+ , testB "counters/pullTree" $ mergeTree 8 <$> counters
344+
345+ ]
346+ where
347+ e :: TestPlan t m => m (Event t Word)
348+ e = events 10
349+
350+ dense, sparse :: TestPlan t m => m [Event t Word]
351+ dense = continuous n 2
352+ sparse = occasional n 8 16
353+
354+ counters :: TestPlan t m => m [Behavior t Int]
355+ counters = countMany =<< sparse
356+
357+
358+
359+
360+
test/Reflex/Plan/Pure.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# LANGUAGE GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2+
3+module Reflex.Plan.Pure where
4+
5+import Reflex
6+import Reflex.Pure
7+import Reflex.TestPlan
8+
9+import Control.Applicative
10+import Control.Monad.Fix
11+import Control.Monad.State
12+import Data.IntMap (IntMap)
13+import qualified Data.IntMap as IntMap
14+import Data.IntSet (IntSet)
15+import qualified Data.IntSet as IntSet
16+
17+import Data.Monoid
18+import Data.Bifunctor
19+import Data.Maybe
20+import Prelude
21+
22+
23+mapToPureEvent :: IntMap a -> Event (Pure Int) a
24+mapToPureEvent m = Event $ flip IntMap.lookup m
25+
26+type TimeM = (->) Int
27+newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix)
28+
29+liftPlan :: TimeM a -> PurePlan a
30+liftPlan = PurePlan . lift
31+
32+instance MonadHold (Pure Int) PurePlan where
33+ hold initial = liftPlan . hold initial
34+
35+instance MonadSample (Pure Int) PurePlan where
36+ sample = liftPlan . sample
37+
38+
39+instance TestPlan (Pure Int) PurePlan where
40+ plan occs = do
41+ PurePlan . modify $ IntSet.union (IntMap.keysSet m)
42+ return $ mapToPureEvent m
43+ where m = IntMap.fromList (first fromIntegral <$> occs)
44+
45+runPure :: PurePlan a -> (a, IntSet)
46+runPure (PurePlan p) = runStateT p mempty $ 0
47+
48+relavantTimes :: IntSet -> IntSet
49+relavantTimes occs = IntSet.fromList [0..l + 1]
50+ where l = fromMaybe 0 (fst <$> IntSet.maxView occs)
51+
52+testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a
53+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)
54+
55+testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)
56+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)
57+
58+
59+
60+
61+
62+
test/Reflex/Plan/Reflex.hsnew file+122
@@ -0,0 +1,122 @@
1+{-# LANGUAGE FunctionalDependencies, BangPatterns, UndecidableInstances, ConstraintKinds, GADTs, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, RecursiveDo, FlexibleContexts, StandaloneDeriving #-}
2+module Reflex.Plan.Reflex
3+ ( TestPlan(..)
4+ , runPlan
5+ , Plan
6+ , Schedule
7+ , Firing (..)
8+ , MonadIORef
9+
10+
11+ , readSchedule
12+ , testSchedule
13+ , readEvent'
14+ , makeDense
15+
16+ , runTestE
17+ , runTestB
18+
19+ ) where
20+
21+import Reflex.Class
22+import Reflex.Host.Class
23+import Reflex.TestPlan
24+
25+import Control.Applicative
26+import Control.Monad
27+import Control.Monad.Identity
28+import Control.Monad.State.Strict
29+
30+import Data.Dependent.Sum (DSum (..))
31+import Data.Monoid
32+import Data.Traversable (traverse, sequenceA)
33+import Data.Maybe
34+import qualified Data.IntMap.Strict as IntMap
35+import Control.Monad.Ref
36+
37+
38+import Data.IntMap.Strict (IntMap)
39+import Data.IORef
40+import System.Mem
41+
42+-- Note: this import must come last to silence warnings from AMP
43+import Prelude
44+
45+type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)
46+
47+data Firing t where
48+ Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t
49+
50+
51+type Schedule t = IntMap [Firing t]
52+
53+-- Implementation of a TestPlan in terms of ReflexHost
54+newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)
55+
56+deriving instance ReflexHost t => Functor (Plan t)
57+deriving instance ReflexHost t => Applicative (Plan t)
58+deriving instance ReflexHost t => Monad (Plan t)
59+
60+deriving instance ReflexHost t => MonadSample t (Plan t)
61+deriving instance ReflexHost t => MonadHold t (Plan t)
62+deriving instance ReflexHost t => MonadFix (Plan t)
63+
64+
65+instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
66+ plan occurances = Plan $ do
67+ (e, ref) <- newEventWithTriggerRef
68+ modify (IntMap.unionWith mappend (firings ref))
69+ return e
70+
71+ where
72+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)
73+ makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
74+
75+
76+firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
77+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
78+
79+runPlan :: (MonadReflexHost t m, MonadIORef m) => Plan t a -> m (a, Schedule t)
80+runPlan (Plan p) = runHostFrame $ runStateT p mempty
81+
82+
83+makeDense :: Schedule t -> Schedule t
84+makeDense s = fromMaybe (emptyRange 0) $ do
85+ (end, _) <- fst <$> IntMap.maxViewWithKey s
86+ return $ IntMap.union s (emptyRange end)
87+ where
88+ emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))
89+
90+
91+-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
92+-- after the last event)
93+-- performGC is called at each frame to test for GC issues
94+testSchedule :: (MonadReflexHost t m, MonadIORef m) => Schedule t -> ReadPhase m a -> m (IntMap a)
95+testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
96+
97+readSchedule :: (MonadReflexHost t m, MonadIORef m) => Schedule t -> ReadPhase m a -> m (IntMap a)
98+readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
99+
100+triggerFrame :: (MonadReflexHost t m, MonadIORef m) => ReadPhase m a -> Int -> [Firing t] -> m a
101+triggerFrame readResult _ occs = do
102+ triggers <- catMaybes <$> traverse firingTrigger occs
103+ fireEventsAndRead triggers readResult
104+
105+
106+readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
107+readEvent' = readEvent >=> sequenceA
108+
109+
110+-- Convenience functions for running tests producing Events/Behaviors
111+runTestB :: (MonadReflexHost t m, MonadIORef m) => Plan t (Behavior t a) -> m (IntMap a)
112+runTestB p = do
113+ (b, s) <- runPlan p
114+ testSchedule s $ sample b
115+
116+runTestE :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (IntMap (Maybe a))
117+runTestE p = do
118+ (e, s) <- runPlan p
119+ h <- subscribeEvent e
120+ testSchedule s (readEvent' h)
121+
122+
test/Reflex/Pure.hsnew file+75
@@ -0,0 +1,75 @@
1+{- | This module provides a pure implementation of Reflex, which is intended
2+to serve as a reference for the semantics of the Reflex class. All implementations
3+of Reflex should produce the same results as this implementation, although performance
4+and laziness/strictness may differ.
5+-}
6+
7+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls, InstanceSigs #-}
8+module Reflex.Pure where
9+
10+import Reflex.Class
11+import Data.Functor.Misc
12+import Data.Functor.Identity
13+import Data.MemoTrie
14+import Data.Dependent.Map (DMap, GCompare)
15+import qualified Data.Dependent.Map as DMap
16+
17+data Pure t
18+
19+-- | The Enum instance of t must be dense: for all x :: t, there must not exist
20+-- any y :: t such that pred x < y < x. The HasTrie instance will be used exclusively
21+-- to memoize functions of t, not for any of its other capabilities.
22+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
23+
24+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
25+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
26+
27+ type PushM (Pure t) = (->) t
28+ type PullM (Pure t) = (->) t
29+
30+ never :: Event (Pure t) a
31+ never = Event $ \_ -> Nothing
32+
33+ constant :: a -> Behavior (Pure t) a
34+ constant x = Behavior $ \_ -> x
35+
36+ push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
37+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
38+
39+ pull :: PullM (Pure t) a -> Behavior (Pure t) a
40+ pull = Behavior . memo
41+
42+ merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
43+ merge events = Event $ memo $ \t ->
44+ let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events
45+ in if DMap.null currentOccurrences
46+ then Nothing
47+ else Just currentOccurrences
48+
49+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
50+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
51+
52+ switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
53+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
54+
55+ coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
56+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
57+
58+instance Ord t => MonadSample (Pure t) ((->) t) where
59+
60+ sample :: Behavior (Pure t) a -> (t -> a)
61+ sample = unBehavior
62+
63+instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
64+
65+ hold :: a -> Event (Pure t) a -> (t -> (Behavior (Pure t) a))
66+ hold initialValue e initialTime = Behavior f
67+ where f = memo $ \sampleTime ->
68+ -- Really, the sampleTime should never be prior to the initialTime,
69+ -- because that would mean the Behavior is being sampled before being created.
70+ if sampleTime <= initialTime
71+ then initialValue
72+ else let lastTime = pred sampleTime
73+ in case unEvent e lastTime of
74+ Nothing -> f lastTime
75+ Just x -> x
test/Reflex/Test.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+
3+module Reflex.Test
4+ ( testAgreement
5+ , compareResult
6+ , runTests
7+
8+ , module Reflex.TestPlan
9+
10+ ) where
11+
12+import Reflex.Spider
13+
14+import Reflex.TestPlan
15+
16+import Reflex.Plan.Pure
17+import Reflex.Plan.Reflex
18+
19+import Control.Monad
20+import Data.Monoid
21+
22+import Data.IntMap (IntMap)
23+
24+--import Data.Foldable
25+import System.Exit
26+
27+import Prelude
28+
29+
30+testAgreement :: TestCase -> IO Bool
31+testAgreement (TestE p) = do
32+ spider <- runSpiderHost $ runTestE p
33+ let results = [("spider", spider)]
34+
35+ compareResult results (testEvent $ runPure p)
36+
37+testAgreement (TestB p) = do
38+ spider <- runSpiderHost $ runTestB p
39+ let results = [("spider", spider)]
40+
41+ compareResult results (testBehavior $ runPure p)
42+
43+
44+compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool
45+compareResult results expected = fmap and $ forM results $ \(name, r) -> do
46+
47+ when (r /= expected) $ do
48+ putStrLn ("Got: " ++ show (name, r))
49+ putStrLn ("Expected: " ++ show expected)
50+ return (r == expected)
51+
52+
53+runTests :: [(String, TestCase)] -> IO ()
54+runTests testCases = do
55+ results <- forM testCases $ \(name, test) -> do
56+ putStrLn $ "Test: " <> name
57+ testAgreement test
58+ exitWith $ if and results
59+ then ExitSuccess
60+ else ExitFailure 1
61+
test/Reflex/Test/CrossImpl.hsnew file+228
@@ -0,0 +1,228 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, BangPatterns, ConstraintKinds #-}
2+module Reflex.Test.CrossImpl (test) where
3+
4+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl, and)
5+
6+import Reflex.Class
7+import Reflex.Host.Class
8+import Reflex.Dynamic
9+import qualified Reflex.Spider.Internal as S
10+import qualified Reflex.Pure as P
11+import Control.Monad.Ref
12+
13+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
14+import qualified Data.Set as Set
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as Map
17+import Control.Arrow (second, (&&&))
18+import Data.Traversable
19+import Data.Foldable
20+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21+import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
22+import Data.Dependent.Map (DSum (..))
23+import System.Mem
24+import System.Exit
25+
26+import System.IO.Unsafe
27+
28+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
29+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
30+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
31+ Just (_, v) -> v
32+
33+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
34+mapToPureEvent m = P.Event $ flip Map.lookup m
35+
36+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
37+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
38+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
39+ _ -> [] -- Doesn't actually make much sense
40+
41+type PureReflexDomain = P.Pure Int
42+type TimeM = (->) Int
43+
44+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)
45+testPure builder (b, e) =
46+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
47+ relevantTimes = relevantTestingTimes (b, e)
48+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
49+ b'' = Map.fromList $ map (id &&& b') relevantTimes
50+ in (b'', e'')
51+
52+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
53+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
54+
55+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
56+ mapMSignals fb _ = fb
57+
58+instance MapMSignals (Event t a) (Event t' a) t t' where
59+ mapMSignals _ fe = fe
60+
61+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
62+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
63+
64+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)
65+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
66+ (re, reTrigger) <- newEventWithTriggerRef
67+ (rb, rbTrigger) <- newEventWithTriggerRef
68+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
69+ (b', e') <- runHostFrame $ builder (b, re)
70+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
71+ let times = relevantTestingTimes (bMap, eMap)
72+ liftIO performGC
73+ outputs <- forM times $ \t -> do
74+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
75+ bOutput <- sample b'
76+ eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do
77+ mret <- readRef reTrigger
78+ let firing = case mret of
79+ Just ret -> [ret :=> Identity val]
80+ Nothing -> []
81+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
82+ liftIO performGC
83+ return (t, (bOutput, eOutput))
84+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
85+
86+tracePerf :: Show a => a -> b -> b
87+tracePerf = flip const
88+
89+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
90+testAgreement builder inputs = do
91+ let identityResult = testPure builder inputs
92+ tracePerf "---------" $ return ()
93+ let spiderResult = testSpider builder inputs
94+ tracePerf "---------" $ return ()
95+ let resultsAgree = identityResult == spiderResult
96+ if resultsAgree
97+ then do putStrLn "Success:"
98+ print identityResult
99+ else do putStrLn "Failure:"
100+ putStrLn $ "Pure result: " <> show identityResult
101+ putStrLn $ "Spider result: " <> show spiderResult
102+ return resultsAgree
103+
104+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
105+
106+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))
107+
108+testCases :: [(String, TestCase)]
109+testCases =
110+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
111+ b' <- hold "123" e
112+ return (b', e)
113+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
114+ e' <- liftM updated $ count e
115+ b' <- hold (0 :: Int) e'
116+ return (b', e')
117+ , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
118+ e' <- onceE $ leftmost [e, e]
119+ return (b, e')
120+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
121+ let e' = fmap (const e) e
122+ b' <- hold never e'
123+ let e'' = switch b'
124+ return (b, e'')
125+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
126+ let e' = flip pushAlways e $ const $ do
127+ let ea = fmap (const "a") e
128+ let eb = fmap (const "b") e
129+ let eab = leftmost [ea, eb]
130+ liftM switch $ hold eab never
131+ e'' = coincidence e'
132+ return (b, e'')
133+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
134+ let e' = flip pushAlways e $ const $ do
135+ let ea = fmap (const "a") e
136+ let eb = fmap (const "b") e
137+ let eab = leftmost [ea, eb]
138+ liftM switch $ hold eab (fmap (const e) e)
139+ e'' = coincidence e'
140+ return (b, e'')
141+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
142+ let e' = leftmost [e, e]
143+ e'' <- liftM switch $ hold e' (fmap (const e) e)
144+ return (b, e'')
145+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
146+ let e' = fmap (const e) e
147+ e'' <- switchPromptly never e'
148+ return (b, e'')
149+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
150+ let e' = fmap (const e) e
151+ e'' <- switchPromptly never $ leftmost [e', e']
152+ return (b, e'')
153+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
154+ let e' = leftmost [e, e]
155+ e'' <- switchPromptly never (fmap (const e) e')
156+ return (b, e'')
157+ , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
158+ let e' = leftmost [e, e]
159+ e'' <- switchPromptly never (fmap (const e') e)
160+ return (b, e'')
161+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
162+ let e' = leftmost [e, e]
163+ e'' <- liftM switch $ hold never (fmap (const e') e)
164+ return (b, e'')
165+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
166+ let e' = flip push e $ \_ -> do
167+ return . Just =<< onceE e
168+ e'' <- switchPromptly never e'
169+ return (b, e'')
170+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
171+ let e' = flip pushAlways e $ \_ -> do
172+ switchPromptly e never
173+ e'' <- switchPromptly never e'
174+ return (b, e'')
175+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
176+ let e' = flip pushAlways e $ \_ -> return $ fmap id e
177+ e'' = coincidence e'
178+ return (b, e'')
179+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
180+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
181+ e'' = coincidence e'
182+ return (b, e'')
183+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
184+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
185+ e'' = coincidence e'
186+ return (b, e'')
187+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
188+ let e' = flip pushAlways e $ \_ -> onceE e
189+ e'' = coincidence e'
190+ return (b, e'')
191+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
192+ let eChild = flip pushAlways e $ const $ do
193+ let eNewValues = leftmost [e, e]
194+ return $ coincidence $ fmap (const eNewValues) eNewValues
195+ e' = coincidence eChild
196+ return (b, e')
197+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
198+ let eChild = flip pushAlways e $ const $ do
199+ let e' = coincidence $ fmap (const e) e
200+ return $ leftmost [e', e']
201+ e'' = coincidence eChild
202+ return (b, e'')
203+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
204+ let e' = leftmost [e, e]
205+ eCoincidences = coincidence $ fmap (const e') e
206+ return (b, eCoincidences)
207+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
208+ eo <- onceE e
209+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
210+ let b' = pull $ sample =<< sample bb
211+ return (b', e)
212+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
213+ bb <- hold "b" e
214+ bd <- hold never . fmap (const e) =<< onceE e
215+ eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e
216+ let eInner = switch bd
217+ e' = leftmost [eOuter, eInner]
218+ return (b, e')
219+ ]
220+
221+test :: IO ()
222+test = do
223+ results <- forM testCases $ \(name, TestCase inputs builder) -> do
224+ putStrLn $ "Test: " <> name
225+ testAgreement builder inputs
226+ exitWith $ if and results
227+ then ExitSuccess
228+ else ExitFailure 1
test/Reflex/Test/Micro.hsnew file+299
@@ -0,0 +1,299 @@
1+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+
3+module Reflex.Test.Micro (testCases) where
4+
5+import Reflex
6+import Reflex.TestPlan
7+
8+import Data.Word
9+import Control.Monad
10+import Control.Applicative
11+import Data.Char
12+import Data.Monoid
13+import Data.Functor.Misc
14+
15+import Data.Foldable
16+
17+import Data.Map (Map)
18+import qualified Data.Map as Map
19+
20+import Prelude
21+
22+testCases :: [(String, TestCase)]
23+testCases =
24+ [ testB "hold" $ hold "0" =<< events1
25+ , testB "count" $ do
26+ b <- current <$> (count =<< events2)
27+ return $ (+ (0::Int)) <$> b
28+
29+ , testB "pull-1" $ do
30+ b <- hold "0" =<< events1
31+ return (id <$> id <$> b)
32+
33+
34+ , testB "pull-2" $ do
35+ b1 <- behavior1
36+ return (id <$> pull $ liftA2 (<>) (sample b1) (sample b1))
37+
38+ , testB "pull-3" $ do
39+ b1 <- behavior1
40+ b2 <- behavior2
41+ return (id <$> pull $ liftA2 (<>) (sample b1) (sample b2))
42+
43+ , testB "pull-4" $ do
44+ es <- planList ["a", "b", "c"]
45+ e <- plan [(0, ())]
46+
47+ b <- hold (constant "") $
48+ pushAlways (const $ hold "z" es) e
49+
50+ return (join b)
51+
52+ , testE "tag-1" $ do
53+ b1 <- behavior1
54+ e <- events2
55+ return (tag b1 e)
56+
57+ , testE "tag-2" $ do
58+ b1 <- behavior1
59+ e <- events2
60+ return (tag (map toUpper <$> b1) e)
61+
62+ , testE "attach-1" $ do
63+ b1 <- behavior1
64+ e <- events2
65+ return (attachWith (++) (map toUpper <$> b1) e)
66+
67+ , testE "leftmost" $ liftA2 leftmost2 events1 events2
68+
69+ , testE "appendEvents-1" $ liftA2 appendEvents events1 events2
70+ , testE "appendEvents-2" $ liftA2 appendEvents events3 events2
71+
72+
73+ , testE "merge-1" $ do
74+ e <- events1
75+ return $ leftmost ["x" <$ e, "y" <$ e]
76+
77+ , testE "merge-2" $ do
78+ e <- events1
79+ let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
80+
81+ let ee = flip pushAlways e $ const $ return m
82+ return $ coincidence ee
83+
84+ , testE "onceE-1" $ do
85+ e <- events1
86+ onceE $ leftmost [e, e]
87+
88+
89+ , testE "onceE-2" $ do
90+ e <- events1
91+ b <- hold never (e <$ e)
92+ onceE $ switch b
93+
94+
95+ , testE "switch-1" $ do
96+ e <- events1
97+ b <- hold never (e <$ e)
98+ return $ switch b
99+
100+ , testE "switch-2" $ do
101+ e <- events1
102+ return $ coincidence $ flip pushAlways e $ const $ do
103+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)
104+
105+ , testE "switch-3" $ do
106+ e <- events1
107+ return $ coincidence $ flip pushAlways e $ const $ do
108+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never
109+
110+ , testE "switch-4" $ do
111+ e <- events1
112+ switch <$> hold (deep e) (e <$ e)
113+
114+
115+ , testE "switch-5" $ do
116+ e <- events1
117+ return $ coincidence $ flip pushAlways e $ const $
118+ return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]
119+
120+ , testE "switch-6" $ do
121+ e <- events1
122+ return $ coincidence $ flip pushAlways e $ const $ do
123+ switch <$> hold ("x" <$ e) (e <$ e)
124+
125+
126+ , testE "switchPromptly-1" $ do
127+ e <- events1
128+ let e' = e <$ e
129+ switchPromptly never $ e <$ e'
130+
131+ , testE "switchPromptly-2" $ do
132+ e <- events1
133+ switchPromptly never $ deep (e <$ e)
134+
135+ , testE "switchPromptly-3" $ do
136+ e <- events1
137+ switchPromptly never $ (e <$ deep e)
138+
139+ , testE "switchPromptly-4" $ do
140+ e <- events1
141+ switchPromptly never $ (deep e <$ e)
142+
143+ , testE "switch-5" $ do
144+ e <- events1
145+ switch <$> hold never (deep e <$ e)
146+
147+ , testE "switchPromptly-5" $ do
148+ e <- events1
149+ switchPromptly never $ flip push e $
150+ const (Just <$> onceE e)
151+
152+ , testE "switchPromptly-6" $ do
153+ e <- events1
154+ switchPromptly never $ flip pushAlways e $
155+ const (switchPromptly e never)
156+
157+ , testE "coincidence-1" $ do
158+ e <- events1
159+ return $ coincidence $ flip pushAlways e $
160+ const $ return (id <$> e)
161+
162+ , testE "coincidence-2" $ do
163+ e <- events1
164+ return $ coincidence $ flip pushAlways e $
165+ const $ return (deep e)
166+
167+ , testE "coincidence-3" $ do
168+ e <- events1
169+ return $ coincidence $ flip pushAlways e $
170+ const $ return (coincidence (e <$ e))
171+
172+ , testE "coincidence-4" $ do
173+ e <- events1
174+ return $ coincidence $ flip pushAlways e $
175+ const (onceE e)
176+
177+ , testE "coincidence-5" $ do
178+ e <- events1
179+ return $ coincidence $ flip pushAlways e $ const $ do
180+ let e' = deep e
181+ return (coincidence (e' <$ e'))
182+
183+ , testE "coincidence-6" $ do
184+ e <- events1
185+ return $ coincidence $ flip pushAlways e $ const $ do
186+ let e' = coincidence (e <$ e)
187+ return $ deep e'
188+
189+ , testE "coincidence-7" $ do
190+ e <- events1
191+ return $ coincidence (deep e <$ e)
192+
193+ , testB "holdWhileFiring" $ do
194+ e <- events1
195+ eo <- onceE e
196+ bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo
197+ return $ pull $ sample =<< sample bb
198+
199+ , testE "joinDyn" $ do
200+ e <- events1
201+ bb <- hold "b" e
202+ bd <- hold never . fmap (const e) =<< onceE e
203+
204+ eOuter <- pushAlways sample . fmap (const bb) <$> onceE e
205+ let eInner = switch bd
206+ return $ leftmost [eOuter, eInner]
207+
208+ , testB "foldDyn" $ do
209+ d <- foldDyn (++) "0" =<< events1
210+ return (current d)
211+
212+ , testB "mapDyn" $ do
213+ d <- foldDyn (++) "0" =<< events1
214+ current <$> mapDyn (map toUpper) d
215+
216+ , testB "combineDyn" $ do
217+ d1 <- foldDyn (++) "0" =<< events1
218+ d2 <- mapDyn (map toUpper) =<< foldDyn (++) "0" =<< events2
219+
220+ current <$> combineDyn (<>) d1 d2
221+ , testE "fan-1" $ do
222+ e <- fmap toMap <$> events1
223+ let es = select (fanMap e) . Const2 <$> values
224+
225+ return (mergeList es)
226+
227+ , testE "fan-2" $ do
228+ e <- fmap toMap <$> events3
229+ let es = select (fanMap e) . Const2 <$> values
230+
231+ return (mergeList es)
232+
233+ , testE "fan-3" $ do
234+ f <- fanMap <$> fmap toMap <$> events3
235+ return $ select f (Const2 'c')
236+
237+ , testE "fan-4" $ do
238+ e <- fmap toMap <$> events1
239+ return $ toUpper <$> select (fanMap e) (Const2 'a')
240+
241+ , testE "fan-5" $ do
242+ e <- fmap toMap <$> events2
243+ return $ toUpper <$> select (fanMap e) (Const2 'c')
244+
245+ , testE "fan-6" $ do
246+ f <- fanMap <$> fmap toMap <$> events1
247+ return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]
248+
249+ -- , testE "switchMerge-1" $ switchMergeMap mempty =<< increasing
250+
251+ -- , testE "switchMerge-2" $ do
252+ -- e <- eventsFrom 0
253+ -- switchMergeMap (Map.singleton 0 e) =<< increasing
254+
255+ -- , testE "switchMerge-3" $ do
256+ -- es <- eventsMany
257+ -- switchMergeMap es =<< increasing
258+
259+ -- , testE "switchMerge-4" $ do
260+ -- es <- eventsMany
261+ -- switchMergeMap es =<< decreasing
262+
263+ ] where
264+
265+ events1, events2, events3 :: TestPlan t m => m (Event t String)
266+ events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]
267+ events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]
268+
269+ events3 = liftA2 appendEvents events1 events2
270+
271+ eventsFrom :: TestPlan t m => Word -> m (Event t Int)
272+ eventsFrom n = plan $ zip [n..8] [1..8]
273+
274+ increasing :: TestPlan t m => m (Event t (Map Int (Event t Int)))
275+ increasing = do
276+ es <- mapM eventsFrom [1..8]
277+ planList $ zipWith Map.singleton [1..8] es
278+
279+ decreasing :: TestPlan t m => m (Event t (Map Int (Event t Int)))
280+ decreasing = planList $ zipWith Map.singleton [1..8] (repeat never)
281+
282+ eventsMany :: TestPlan t m => m (Map Int (Event t Int))
283+ eventsMany = do
284+ es <- mapM eventsFrom [8,7..1]
285+ return $ Map.fromList $ zip [1..8] es
286+
287+
288+ values = "abcde"
289+ toMap str = Map.fromList $ map (\c -> (c, c)) str
290+
291+
292+ behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)
293+ behavior1 = hold "1" =<< events1
294+ behavior2 = hold "2" =<< events2
295+
296+ deep e = leftmost [e, e]
297+ leftmost2 e1 e2 = leftmost [e1, e2]
298+
299+
test/Reflex/Test/RunAll.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
2+
3+module Main (main) where
4+
5+import Reflex.Test
6+
7+import qualified Reflex.Bench.Focused as Focused
8+import qualified Reflex.Test.Micro as Micro
9+import Data.Functor
10+import Data.Bifunctor
11+import Data.List
12+
13+import System.Exit
14+import System.Environment
15+
16+import Prelude
17+
18+matchPrefixes :: [String] -> (String -> Bool)
19+matchPrefixes [] = const True
20+matchPrefixes args = \name -> any (`isPrefixOf` name) args
21+
22+
23+main :: IO ()
24+main = do
25+ args <- getArgs
26+
27+ case args of
28+ ["--list"] -> mapM_ putStrLn (fst <$> allTests) >> exitWith (ExitFailure 1)
29+ _ -> case filter (matchPrefixes args . fst) allTests of
30+ [] -> putStrLn "filter did not match any tests" >> exitWith (ExitFailure 1)
31+ tests -> runTests tests
32+
33+ where
34+ allTests = concat
35+ [ makeGroup "micro" Micro.testCases
36+ , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)
37+ , makeGroup "firing 1000" (Focused.firing 1000)
38+ , makeGroup "merge 100" (Focused.merging 100)
39+ , makeGroup "fan 50" (Focused.fans 50)
40+ ]
41+
42+ makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests
43+
44+
test/Reflex/TestPlan.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE FunctionalDependencies, BangPatterns, UndecidableInstances, ConstraintKinds, GADTs, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, RecursiveDo, FlexibleContexts, StandaloneDeriving #-}
2+module Reflex.TestPlan
3+ ( TestPlan(..)
4+
5+ , TestCase (..)
6+ , testE, testB
7+ , TestE, TestB
8+
9+ , planList
10+
11+ ) where
12+
13+import Reflex.Class
14+import Control.Monad.Fix
15+import Data.Word
16+
17+
18+import Prelude
19+
20+class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where
21+ -- | Speicify a plan of an input Event firing
22+ -- Occurances must be in the future (i.e. Time > 0)
23+ -- Initial specification is
24+
25+ plan :: [(Word, a)] -> m (Event t a)
26+
27+
28+planList :: TestPlan t m => [a] -> m (Event t a)
29+planList xs = plan $ zip [1..] xs
30+
31+type TestE a = forall t m. TestPlan t m => m (Event t a)
32+type TestB a = forall t m. TestPlan t m => m (Behavior t a)
33+
34+data TestCase where
35+ TestE :: (Show a, Eq a) => TestE a -> TestCase
36+ TestB :: (Show a, Eq a) => TestB a -> TestCase
37+
38+-- Helpers to declare test cases
39+testE :: (Eq a, Show a) => String -> TestE a -> (String, TestCase)
40+testE name test = (name, TestE test)
41+
42+testB :: (Eq a, Show a) => String -> TestB a -> (String, TestCase)
43+testB name test = (name, TestB test)
44+
test/hlint.hsdeleted−39
@@ -1,39 +0,0 @@
1−module Main where
2−
3−import Control.Monad
4−import Language.Haskell.HLint (hlint)
5−import System.Directory
6−import System.Exit (exitFailure, exitSuccess)
7−import System.FilePath
8−import System.FilePath.Find
9−
10−main :: IO ()
11−main = do
12− pwd <- getCurrentDirectory
13− let runHlint f = hlint $ f:
14− [ "--ignore=Redundant do"
15− , "--ignore=Use camelCase"
16− , "--ignore=Redundant $"
17− , "--ignore=Use &&"
18− , "--ignore=Use &&&"
19− , "--ignore=Use const"
20− , "--ignore=Use >=>"
21− , "--ignore=Use ."
22− , "--ignore=Use unless"
23− , "--ignore=Reduce duplication"
24− , "--cpp-define=USE_TEMPLATE_HASKELL"
25− , "--ignore=Use tuple-section"
26− , "--ignore=Unused LANGUAGE pragma" -- hlint3 falsely believes that TypeOperators is not needed
27− ]
28− recurseInto = and <$> sequence
29− [ fileType ==? Directory
30− , fileName /=? ".git"
31− ]
32− matchFile = and <$> sequence
33− [ extension ==? ".hs"
34− ]
35− files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.
36− ideas <- fmap concat $ forM files $ \f -> do
37− putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
38− runHlint f
39− if null ideas then exitSuccess else exitFailure
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