├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CONTRIBUTING.md ├── ChangeLog.md ├── LICENSE ├── Quickref.md ├── README.md ├── Setup.hs ├── bench-cbits └── checkCapability.c ├── bench ├── Main.hs └── RunAll.hs ├── cabal.haskell-ci ├── cabal.project ├── dep └── reflex-platform │ ├── default.nix │ ├── github.json │ └── thunk.nix ├── nixpkgs ├── default.nix ├── github.json └── thunk.nix ├── overlay.nix ├── reflex.cabal ├── release.nix ├── shell.nix ├── src.nix ├── src ├── Control │ └── Monad │ │ └── ReaderIO.hs ├── Data │ ├── AppendMap.hs │ ├── FastMutableIntMap.hs │ ├── FastWeakBag.hs │ ├── Map │ │ └── Misc.hs │ └── WeakBag.hs ├── Reflex.hs └── Reflex │ ├── Adjustable │ └── Class.hs │ ├── BehaviorWriter │ ├── Base.hs │ └── Class.hs │ ├── Class.hs │ ├── Collection.hs │ ├── Dynamic.hs │ ├── Dynamic │ ├── TH.hs │ └── Uniq.hs │ ├── DynamicWriter.hs │ ├── DynamicWriter │ ├── Base.hs │ └── Class.hs │ ├── EventWriter.hs │ ├── EventWriter │ ├── Base.hs │ └── Class.hs │ ├── FastWeak.hs │ ├── FunctorMaybe.hs │ ├── Host │ ├── Class.hs │ └── Headless.hs │ ├── Network.hs │ ├── NotReady │ └── Class.hs │ ├── Optimizer.hs │ ├── PerformEvent │ ├── Base.hs │ └── Class.hs │ ├── PostBuild │ ├── Base.hs │ └── Class.hs │ ├── Profiled.hs │ ├── Pure.hs │ ├── Query │ ├── Base.hs │ └── Class.hs │ ├── Requester │ ├── Base.hs │ ├── Base │ │ └── Internal.hs │ └── Class.hs │ ├── Spider.hs │ ├── Spider │ └── Internal.hs │ ├── Time.hs │ ├── TriggerEvent │ ├── Base.hs │ └── Class.hs │ ├── Widget │ └── Basic.hs │ └── Workflow.hs ├── stylize └── test ├── Adjustable.hs ├── DebugCycles.hs ├── EventWriterT.hs ├── GC.hs ├── Headless.hs ├── QueryT.hs ├── Reflex ├── Bench │ └── Focused.hs ├── Plan │ ├── Pure.hs │ └── Reflex.hs ├── Test.hs ├── Test │ ├── CrossImpl.hs │ └── Micro.hs └── TestPlan.hs ├── RequesterT.hs ├── Test └── Run.hs ├── hlint.hs ├── rootCleanup.hs └── semantics.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: github-action 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | strategy: 8 | fail-fast: false 9 | matrix: 10 | ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.7', '9.0.2', '9.2.5', '9.4.5', '9.6.1', '9.8.2', '9.10.1', '9.12.1'] 11 | os: ['ubuntu-latest', 'macos-latest'] 12 | runs-on: ${{ matrix.os }} 13 | 14 | name: GHC ${{ matrix.ghc }} on ${{ matrix.os }} 15 | steps: 16 | 17 | - uses: actions/checkout@v3 18 | 19 | - uses: haskell/actions/setup@v2 20 | with: 21 | ghc-version: ${{ matrix.ghc }} 22 | cabal-version: '3.10.3.0' 23 | 24 | - name: Cache 25 | uses: actions/cache@v3 26 | env: 27 | cache-name: cache-cabal 28 | with: 29 | path: ~/.cabal 30 | key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 31 | restore-keys: | 32 | ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}- 33 | ${{ runner.os }}-${{ matrix.ghc }}-build- 34 | ${{ runner.os }}-${{ matrix.ghc }}- 35 | ${{ runner.os }} 36 | 37 | - name: Install dependencies 38 | run: | 39 | cabal update 40 | cabal build --only-dependencies --enable-tests --enable-benchmarks 41 | 42 | - name: Build 43 | run: cabal build --enable-tests --enable-benchmarks all 44 | 45 | - name: Run tests 46 | run: cabal test --enable-tests all 47 | 48 | - if: matrix.ghc != '8.4.4' 49 | # docs aren't built on ghc 8.4.4 because some dependency docs don't build on older GHCs 50 | name: Build Docs 51 | run: cabal haddock 52 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal.sandbox.config 3 | .cabal-sandbox/ 4 | dist-* 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_hi 11 | *.dyn_o 12 | *.p_hi 13 | *.p_o 14 | *.js_dyn_hi 15 | *.js_dyn_o 16 | *.js_p_hi 17 | *.js_p_o 18 | *.js_o 19 | *.js_hi 20 | .virthualenv 21 | .hsenv* 22 | *.*~ 23 | *.swp 24 | .DS_Store 25 | backend.pid 26 | backend.out 27 | .shelly 28 | TAGS 29 | tags 30 | *~ 31 | *.orig 32 | hsenv.log 33 | \#*# 34 | .#* 35 | /ghci-tmp 36 | *.dump-* 37 | *.verbose-core2core 38 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 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 154 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 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 reflex you were using. If you're using a github checkout, provide the git hash. 19 | * Describe how you're building reflex (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 reflex.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 | 67 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for reflex 2 | 3 | ## 0.9.3.4 4 | 5 | * Support random 1.3 6 | 7 | ## 0.9.3.3 8 | 9 | * Add support for GHC 9.12 10 | * Loosen version bounds 11 | 12 | ## 0.9.3.2 13 | 14 | * Add support for witherable 0.5 15 | 16 | ## 0.9.3.1 17 | 18 | * Add support for GHC 9.8 and 9.10 19 | 20 | ## 0.9.3.0 21 | 22 | * Headless Host: Generalize to allow returning arbitrary types 23 | 24 | ## 0.9.2.0 25 | 26 | * Add MonadMask, MonadCatch, MonadThrow instances 27 | 28 | ## 0.9.1.0 29 | 30 | * Headless Host: Add some MonadSample, MonadHold, and MonadFix instances 31 | 32 | ## 0.9.0.1 33 | 34 | * Add support for ghc-9.6 35 | 36 | ## 0.9.0.0 37 | 38 | * Breaking Change: Filter updates to `listWithKey` child widgets so that changes to the input Map don't cause spurious updates to unaffected children. This imposes an `Eq` constraint on the child values. 39 | * Expose all Requester internals in Reflex.Requester.Base.Internal 40 | * [Add EventWriter instance for RequesterT #469](https://github.com/reflex-frp/reflex/pull/469) 41 | 42 | ## 0.8.2.2 43 | 44 | * Require witherable >= 0.4 and, hence, a newer monoidal-containers 45 | * Support newer constraints-extras (0.4) 46 | 47 | ## 0.8.2.1 48 | 49 | * Fix build for GHC 9.2 50 | * Require patch >= 0.0.7.0 51 | 52 | ## 0.8.2.0 53 | 54 | * Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once. 55 | 56 | ## 0.8.1.1 57 | 58 | * Allow newer hlint for older GHCs, and add upper bound for newer GHCs 59 | 60 | ## 0.8.1.0 61 | 62 | * Add support for GHC 8.10 63 | * Drop support for GHC < 8.4 64 | 65 | ## 0.8.0.0 66 | 67 | * Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0. 68 | 69 | ## 0.7.2.0 -- *Deprecated* 70 | 71 | * ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`. 72 | * Extend some dependency version bounds 73 | * Fix HLint 3 test 74 | 75 | ## 0.7.1.1 76 | 77 | *Backport release*. 78 | Changes do not carry forward to 0.7.2.0. 79 | 80 | * Add support for GHC 8.10 81 | * Drop support for GHC < 8.4 82 | * Extend some dependency version bounds 83 | * Fix HLint 3 test 84 | 85 | ## 0.7.1.0 86 | 87 | * ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment. 88 | * ([#420](https://github.com/reflex-frp/reflex/pull/420)) Add a [`Data.Zip.Unzip`](https://hackage.haskell.org/package/semialign-1.1/docs/Data-Zip.html#t:Unzip) instance for `Event`. 89 | * ([#419](https://github.com/reflex-frp/reflex/pull/419)) Add `distributeIntMapOverDynPure` and `joinDynThroughIntMap` as convenience functions for working with `Dynamic` `IntMap`s. 90 | 91 | 92 | ## 0.7.0.0 93 | 94 | * Add lifting instances for most classes to `Reflex.Profiled.Profiled`. ([#398](https://github.com/reflex-frp/reflex/pull/398)) 95 | * Class `MonadQuery t q m` now has a `Monad m` superclass constraint. ([#400](https://github.com/reflex-frp/reflex/pull/400)) 96 | * **(Breaking change)** Rename class `MonadBehaviorWriter` -> `BehaviorWriter` for consistency with `EventWriter`/`DynamicWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401)) 97 | * Introduce deprecated alias `MonadBehaviorWriter = BehaviorWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401)) 98 | * Fix bug in spider where event subscriptions would be prematurely finalized due to over-aggressive inlining. ([#409](https://github.com/reflex-frp/reflex/pull/409)) 99 | * Add instances of `PerformEvent` and `TriggerEvent` for `MaybeT`. ([#395](https://github.com/reflex-frp/reflex/pull/395)) 100 | 101 | ## 0.6.4.1 102 | 103 | * Fix a bug in the Reflex Profiled transformer where 104 | `Reflex.Class.mergeIncrementalG` and 105 | `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced 106 | itself instead of the inner transformed timeline, causing an 107 | infinite loop. 108 | 109 | ## 0.6.4 110 | 111 | * Support GHC 8.8 112 | 113 | * Add `Reflex.Query.Base.mapQueryT`. See that module for documentation 114 | 115 | * The `Reflex.Patch.*` modules were moved to the `patch` library. 116 | They are `Data.Patch.*` there, but reexported under their old names for backwards compatability here. 117 | 118 | * Additional instances for `Query` classes for basic types. 119 | 120 | * Add cabal flags `debug-propagation` and `debug-event-cycles` to build in debugging 121 | code for performance and for cyclic dependencies between events 122 | 123 | ## 0.6.3 124 | 125 | * `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. 126 | They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively. 127 | 128 | * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. 129 | 130 | * Add missing `NotReady` instances: 131 | - `instance NotReady (SpiderTimeline x) (SpiderHost x)` 132 | - `instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))` 133 | 134 | ## 0.6.2.4 135 | 136 | * Update to monoidal-containers 0.6 137 | 138 | ## 0.6.2.3 139 | 140 | * Add an upper-bound to witherable 141 | 142 | ## 0.6.2.2 143 | 144 | * Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not. 145 | 146 | * Update version bounds to fix some CI failures 147 | 148 | * Add travis CI configuration 149 | 150 | ## 0.6.2.1 151 | 152 | * Generalize `fan` to `fanG` to take a `DMap` with non-`Identity` 153 | functor: 154 | * `fan` to `fanG` 155 | * `EventSelectorG` for `fanG` result selector. 156 | 157 | * Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior. 158 | * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce) 159 | * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic 160 | 161 | * Generalize merging functions: 162 | `merge` to `mergeG`, 163 | `mergeIncremental` to `mergeIncrementalG`, 164 | `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. 165 | 166 | * Generalize distribute function: 167 | `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`, 168 | 169 | ## 0.6.2.0 170 | 171 | * Fix `holdDyn` so that it is lazy in its event argument 172 | These produce `DMap`s whose values needn't be `Identity`. 173 | 174 | * Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`). 175 | 176 | * Fix `holdDyn` so that it is lazy in its event argument. 177 | 178 | ## 0.6.1.0 179 | 180 | * Re-export all of `Data.Map.Monoidal` 181 | 182 | * Fix `QueryT` and `RequesterT` tests 183 | 184 | ## 0.6.0.0 -- 2019-03-20 185 | 186 | * Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now. 187 | 188 | * Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name. 189 | 190 | * Remove many deprecated functions. 191 | 192 | * Add a `Num` instance for `Dynamic`. 193 | 194 | * Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you. 195 | 196 | * Add `withRequesterT` to map functions over the request and response of a `RequesterT`. 197 | 198 | * Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance. 199 | 200 | * Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details. 201 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Obsidian Systems LLC 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [Reflex](https://reflex-frp.org/) 2 | 3 | [![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE) 4 | 5 | Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse. 6 | 7 | Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface. 8 | 9 | **Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).** 10 | 11 | ## Resources 12 | 13 | * [Official Website](https://reflex-frp.org) 14 | * [Quick Reference](Quickref.md) 15 | * [Reflex-DOM](https://github.com/reflex-frp/reflex-dom): A framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps. 16 | * [Obelisk](https://github.com/obsidiansystems/obelisk#obelisk): A framework built on Reflex and Reflex-DOM for functional reactive web and mobile applications, with batteries included. 17 | * [Get started with Reflex](https://github.com/reflex-frp/reflex-platform) 18 | * [#reflex-frp:matrix.org](https://matrix.to/#/#reflex-frp:matrix.org): Official Matrix room 19 | * [/r/reflexfrp](https://www.reddit.com/r/reflexfrp) 20 | * [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4) 21 | 22 | ## Hacking 23 | 24 | From the root of a [Reflex Platform](https://github.com/reflex-frp/reflex-platform) checkout, run `./scripts/hack-on haskell-overlays/reflex-packages/dep/reflex`. This will check out the reflex source code into the `haskell-overlays/reflex-packages/dep/reflex` directory. You can then point that checkout at your fork, make changes, etc. Use the `./try-reflex` or `./scripts/work-on` scripts to start a shell in which you can test your changes. 25 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench-cbits/checkCapability.c: -------------------------------------------------------------------------------- 1 | #include 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 | } 209 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | -- The instance for NFData (TVar a) is an orphan, but necessary here 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | module Main where 11 | 12 | import Control.Concurrent.STM 13 | import Control.DeepSeq 14 | import Control.Exception (evaluate) 15 | import Control.Monad 16 | import Control.Monad.Identity 17 | import Control.Monad.IO.Class 18 | import Criterion.Main 19 | import Data.Dependent.Map (DMap) 20 | import qualified Data.Dependent.Map as DMap 21 | import Data.Dependent.Sum 22 | import Data.Functor.Misc 23 | import Data.IORef 24 | import Data.Maybe (fromJust) 25 | import Reflex 26 | import Reflex.Host.Class 27 | 28 | main :: IO () 29 | main = defaultMain 30 | [ bgroup "micro" micros ] 31 | 32 | instance NFData (TVar a) where 33 | rnf x = seq x () 34 | 35 | newtype WHNF a = WHNF a 36 | instance NFData (WHNF a) where 37 | rnf (WHNF a) = seq a () 38 | 39 | withSetup :: NFData b => String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark 40 | withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) -> 41 | bench name . nfIO $ runSpiderHost (action a) 42 | 43 | withSetupWHNF :: String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark 44 | withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) -> 45 | bench name . whnfIO $ runSpiderHost (action a) 46 | 47 | micros :: [Benchmark] 48 | micros = 49 | [ bench "newIORef" $ whnfIO $ void $ newIORef () 50 | , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef) 51 | , bench "newTVar" $ whnfIO $ void $ newTVarIO () 52 | , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO) 53 | , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $ 54 | \trigger -> return () <$ evaluate trigger 55 | , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef 56 | , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst 57 | , withSetupWHNF "subscribeSwitch" 58 | (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef) 59 | (subscribeEvent . switch) 60 | , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev 61 | , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst) 62 | , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst) 63 | , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return () 64 | , withSetupWHNF "fireEventsAndRead(single/single)" 65 | (newEventWithTriggerRef >>= subscribePair) 66 | (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd) 67 | , withSetupWHNF "fireEventsOnly" 68 | (newEventWithTriggerRef >>= subscribePair) 69 | (\(_, trigger) -> do 70 | key <- fromJust <$> liftIO (readIORef trigger) 71 | fireEvents [key :=> Identity (42 :: Int)]) 72 | , withSetupWHNF "fireEventsAndRead(head/merge1)" 73 | (setupMerge 1 >>= subscribePair) 74 | (\(subd, t:_) -> fireAndRead t (42 :: Int) subd) 75 | , withSetupWHNF "fireEventsAndRead(head/merge100)" 76 | (setupMerge 100 >>= subscribePair) 77 | (\(subd, t:_) -> fireAndRead t (42 :: Int) subd) 78 | , withSetupWHNF "fireEventsAndRead(head/merge10000)" 79 | (setupMerge 10000 >>= subscribePair) 80 | (\(subd, t:_) -> fireAndRead t (42 :: Int) subd) 81 | , withSetupWHNF "fireEventsOnly(head/merge100)" 82 | (setupMerge 100 >>= subscribePair) 83 | (\(_, t:_) -> do 84 | key <- fromJust <$> liftIO (readIORef t) 85 | fireEvents [key :=> Identity (42 :: Int)]) 86 | , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev 87 | , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample 88 | ] 89 | 90 | setupMerge :: Int 91 | -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity) 92 | , [IORef (Maybe (EventTrigger Spider a))] 93 | ) 94 | setupMerge num = do 95 | (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef 96 | let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs] 97 | pure (merge m, triggers) 98 | 99 | subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b) 100 | subscribePair (ev, b) = (,b) <$> subscribeEvent ev 101 | 102 | fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b 103 | -> SpiderHost Global (Maybe b) 104 | fireAndRead trigger val subd = do 105 | key <- fromJust <$> liftIO (readIORef trigger) 106 | fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence 107 | -------------------------------------------------------------------------------- /bench/RunAll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ForeignFunctionInterface #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PatternSynonyms #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TupleSections #-} 14 | {-# LANGUAGE TypeSynonymInstances #-} 15 | {-# LANGUAGE ViewPatterns #-} 16 | {-# OPTIONS_GHC -fno-warn-orphans #-} 17 | 18 | module Main where 19 | 20 | import Criterion.Main 21 | import Criterion.Types 22 | 23 | import Reflex 24 | import Reflex.Host.Class 25 | 26 | import Reflex.Plan.Reflex 27 | import Reflex.TestPlan 28 | 29 | import qualified Reflex.Bench.Focused as Focused 30 | import Reflex.Spider.Internal (SpiderEventHandle) 31 | 32 | import Control.Applicative 33 | import Control.DeepSeq (NFData (..)) 34 | 35 | import Prelude 36 | import System.IO 37 | import System.Mem 38 | 39 | import Control.Arrow 40 | import Control.Concurrent 41 | import Control.Concurrent.STM 42 | import Control.Exception 43 | import Control.Monad 44 | import Control.Monad.Trans 45 | import Data.Bool 46 | import Data.Function 47 | import Data.Int 48 | import Data.IORef 49 | import Data.Monoid 50 | import Data.Time.Clock 51 | import Debug.Trace.LocationTH 52 | import GHC.Stats 53 | import System.Environment 54 | import System.Mem.Weak 55 | import System.Process 56 | import Text.Read 57 | 58 | import Unsafe.Coerce 59 | 60 | import Data.Map (Map) 61 | import qualified Data.Map as Map 62 | 63 | type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t)) 64 | 65 | 66 | setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (EventHandle t a, Schedule t) 67 | setupFiring p = do 68 | (e, s) <- runPlan p 69 | h <- subscribeEvent e 70 | return (h, s) 71 | 72 | -- Hack to avoid the NFData constraint for EventHandle which is a synonym 73 | newtype Ignore a = Ignore a 74 | instance NFData (Ignore a) where 75 | rnf !_ = () 76 | 77 | instance NFData (SpiderEventHandle x a) where 78 | rnf !_ = () 79 | 80 | instance NFData (Behavior t a) where 81 | rnf !_ = () 82 | 83 | instance NFData (Firing t) where 84 | rnf !_ = () 85 | 86 | -- Measure the running time 87 | benchFiring :: forall t m. (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> TestCase -> Int -> IO () 88 | benchFiring runHost tc n = runHost $ do 89 | let runIterations :: m a -> m () 90 | runIterations test = replicateM_ (10*n) $ do 91 | result <- test 92 | liftIO $ evaluate result 93 | case tc of 94 | TestE p -> do 95 | (h, s) <- setupFiring p 96 | runIterations $ readSchedule_ s $ readEvent' h 97 | TestB p -> do 98 | (b, s) <- runPlan p 99 | runIterations $ readSchedule_ (makeDense s) $ sample b 100 | 101 | waitForFinalizers :: IO () 102 | waitForFinalizers = do 103 | performGC 104 | x <- getCurrentTime 105 | isFinalized <- newIORef False 106 | mkWeakPtr x $ Just $ writeIORef isFinalized True 107 | performGC 108 | fix $ \loop -> do 109 | f <- readIORef isFinalized 110 | unless f $ do 111 | threadDelay 1 112 | loop 113 | 114 | benchmarks :: [(String, Int -> IO ())] 115 | benchmarks = implGroup "spider" runSpiderHost cases 116 | where 117 | implGroup :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> [(String, TestCase)] -> [(String, Int -> IO ())] 118 | implGroup name runHost = group name . fmap (second (benchFiring runHost)) 119 | group name = fmap $ first ((name <> "/") <>) 120 | sub n frames = group ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames 121 | firing n = group ("firing " <> show n) $ Focused.firing n 122 | merging n = group ("merging " <> show n) $ Focused.merging n 123 | dynamics n = group ("dynamics " <> show n) $ Focused.dynamics n 124 | cases = concat 125 | [ sub 100 40 126 | , dynamics 100 127 | , dynamics 1000 128 | , firing 1000 129 | , firing 10000 130 | , merging 10 131 | , merging 50 132 | , merging 100 133 | , merging 200 134 | ] 135 | 136 | pattern RunTestCaseFlag = "--run-test-case" 137 | 138 | spawnBenchmark :: String -> Benchmark 139 | spawnBenchmark name = bench name . toBenchmarkable $ \n -> do 140 | self <- getExecutablePath 141 | callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"] 142 | 143 | foreign import ccall unsafe "myCapabilityHasOtherRunnableThreads" myCapabilityHasOtherRunnableThreads :: IO Bool 144 | 145 | main :: IO () 146 | main = do 147 | args <- getArgs 148 | case args of 149 | RunTestCaseFlag : t -> case t of 150 | [name, readMaybe -> Just count] -> do 151 | case lookup name benchmarks of 152 | Just testCase -> testCase count 153 | performGC 154 | fix $ \loop -> bool (return ()) (yield >> loop) =<< myCapabilityHasOtherRunnableThreads 155 | return () 156 | _ -> $failure "--run-test-case: expected test name and iteration count to follow" 157 | _ -> defaultMainWith (defaultConfig { timeLimit = 20, csvFile = Just "dmap-original.csv", reportFile = Just "report.html" }) $ fmap (spawnBenchmark . fst) benchmarks 158 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: xenial 2 | benchmarks: False 3 | unconstrained: False 4 | installed: -all 5 | 6 | -- https://github.com/haskell/cabal/issues/6106 7 | install-dependencies: False 8 | 9 | constraint-set no-th 10 | constraints: reflex -use-template-haskell 11 | 12 | constraint-set old-these 13 | ghc: <8.8 14 | constraints: these <1 15 | 16 | constraint-set old-witherable 17 | constraints: witherable <0.3.2 18 | 19 | constraint-set debug-propagation 20 | constraints: reflex +debug-propagation 21 | 22 | constraint-set debug-cycles 23 | constraints: reflex +debug-cycles 24 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /dep/reflex-platform/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import (import ./thunk.nix) -------------------------------------------------------------------------------- /dep/reflex-platform/github.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "reflex-frp", 3 | "repo": "reflex-platform", 4 | "branch": "develop", 5 | "private": false, 6 | "rev": "6c8830e059a6d2859cb1b65acefed3c2f1d216d3", 7 | "sha256": "06kv45yq8qan0p22wzj5c9mx11ns1wddyqjr1xasjjkf6gaf0080" 8 | } 9 | -------------------------------------------------------------------------------- /dep/reflex-platform/thunk.nix: -------------------------------------------------------------------------------- 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 (builtins.fetchTarball { 6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; 7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; 8 | }) {}).fetchFromGitHub { 9 | inherit owner repo rev sha256 fetchSubmodules private; 10 | }; 11 | json = builtins.fromJSON (builtins.readFile ./github.json); 12 | in fetch json -------------------------------------------------------------------------------- /nixpkgs/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import (import ./thunk.nix) -------------------------------------------------------------------------------- /nixpkgs/github.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "NixOS", 3 | "repo": "nixpkgs", 4 | "branch": "nixpkgs-unstable", 5 | "private": false, 6 | "rev": "c7eb65213bd7d95eafb8c5e2e181f04da103d054", 7 | "sha256": "1glf6j13hbwi459qrc8kkkhfw27a08vdg17sr3zwhadg4bkxz5ia" 8 | } 9 | -------------------------------------------------------------------------------- /nixpkgs/thunk.nix: -------------------------------------------------------------------------------- 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 (builtins.fetchTarball { 6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz"; 7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr"; 8 | }) {}).fetchFromGitHub { 9 | inherit owner repo rev sha256 fetchSubmodules private; 10 | }; 11 | json = builtins.fromJSON (builtins.readFile ./github.json); 12 | in fetch json -------------------------------------------------------------------------------- /overlay.nix: -------------------------------------------------------------------------------- 1 | { haskellLib, self, super }: 2 | { 3 | # jailbreak here because callHackageDirect doesn't give us a way to get the latest revision of a package 4 | # 0.1.0.0-r3 would work just fine 5 | commutative-semigroups = haskellLib.doJailbreak (self.callHackageDirect { 6 | pkg = "commutative-semigroups"; 7 | ver = "0.1.0.0"; 8 | sha256 = "0xmv20n3iqjc64xi3c91bwqrg8x79sgipmflmk21zz4rj9jdkv8i"; 9 | } {}); 10 | patch = self.callHackageDirect { 11 | pkg = "patch"; 12 | ver = "0.0.8.1"; 13 | sha256 = "0q5rxnyilhbnfph48fnxbclggsbbhs0pkn0kfiadm0hmfr440cgk"; 14 | } {}; 15 | } 16 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | { reflex-platform-fun ? import ./dep/reflex-platform 2 | , supportedSystems ? ["x86_64-linux" "x86_64-darwin"] 3 | }: 4 | 5 | let 6 | native-reflex-platform = reflex-platform-fun { __useNewerCompiler = true; }; 7 | inherit (native-reflex-platform.nixpkgs) lib; 8 | perPlatform = lib.genAttrs supportedSystems (system: let 9 | reflex-platform = reflex-platform-fun { inherit system; __useNewerCompiler = true; }; 10 | compilers = [ 11 | "ghc" 12 | "ghcjs" 13 | ] ++ lib.optionals (reflex-platform.androidSupport) [ 14 | "ghcAndroidAarch64" 15 | "ghcAndroidAarch32" 16 | ] ++ lib.optionals (reflex-platform.iosSupport) [ 17 | "ghcIosAarch64" 18 | ]; 19 | variations = map (v: "reflex" + v) [ 20 | "-dontUseTemplateHaskell" 21 | "" 22 | ]; 23 | pkgs = import ./nixpkgs { inherit system; }; 24 | sharedOverrides = self: super: { 25 | exception-transformers = pkgs.haskell.lib.dontCheck super.exception-transformers; 26 | }; 27 | nixpkgsGhcs = 28 | let 29 | nixGhc902 = pkgs.haskell.packages.ghc902.override { overrides = sharedOverrides; }; 30 | nixGhc945 = pkgs.haskell.packages.ghc945.override { overrides = sharedOverrides; }; 31 | nixGhc961 = pkgs.haskell.packages.ghc961.override { 32 | overrides = self: super: sharedOverrides self super // { 33 | these-lens = self.callHackageDirect { 34 | pkg = "these-lens"; 35 | ver = "1.0.1.3"; 36 | sha256 = "0n1vkr57jz5yvy4jm15v5cs42rp342ni0gisib7aqyhibpicqs5c"; 37 | } {}; 38 | these = self.callHackageDirect { 39 | pkg = "these"; 40 | ver = "1.2"; 41 | sha256 = "1iaaq1fsvg8c3l0czcicshkmbbr00hnwkdamjbkljsa1qvlilaf0"; 42 | } {}; 43 | lens = self.callHackageDirect { 44 | pkg = "lens"; 45 | ver = "5.2.2"; 46 | sha256 = "0c4a421sxfjm1cj3nvgwkr4glll23mqnsvs2iv5qh85931h2f3cy"; 47 | } {}; 48 | 49 | assoc = self.callHackageDirect { 50 | pkg = "assoc"; 51 | ver = "1.1"; 52 | sha256 = "1krvcafrbj98z5hv55gq4zb1in5yd71nmz9zdiqgnywjzbrvpf75"; 53 | } {}; 54 | 55 | strict = self.callHackageDirect { 56 | pkg = "strict"; 57 | ver = "0.5"; 58 | sha256 = "02iyvrr7nd7fnivz78lzdchy8zw1cghqj1qx2yzbbb9869h1mny7"; 59 | } {}; 60 | 61 | hlint = self.callHackageDirect { 62 | pkg = "hlint"; 63 | ver = "3.5"; 64 | sha256 = "1np43k54918v54saqqgnd82ccd6225njwxpg2031asi70jam80x9"; 65 | } {}; 66 | 67 | patch = self.callHackageDirect { 68 | pkg = "patch"; 69 | ver = "0.0.8.3"; 70 | sha256 = "054slcrlsdcs6azwph6v3vgsgk939ax7ax9xw76whywkrim20n1w"; 71 | } {}; 72 | }; 73 | }; 74 | in 75 | { 76 | ghc902 = nixGhc902.callCabal2nix "reflex" (import ./src.nix) {}; 77 | ghc945 = nixGhc945.callCabal2nix "reflex" (import ./src.nix) {}; 78 | ghc961 = nixGhc961.callCabal2nix "reflex" (import ./src.nix) {}; 79 | }; 80 | compilerPkgs = lib.genAttrs compilers (ghc: let 81 | variationPkgs = lib.genAttrs variations (variation: let 82 | reflex-platform = reflex-platform-fun { 83 | inherit system; 84 | __useNewerCompiler = true; 85 | __useTemplateHaskell = variation == "reflex"; # TODO hack 86 | haskellOverlays = [ 87 | (self: super: import ./overlay.nix { inherit self super; haskellLib = native-reflex-platform.nixpkgs.haskell.lib; }) 88 | # Use this package's source for reflex 89 | (self: super: { 90 | _dep = super._dep // { reflex = import ./src.nix; }; 91 | }) 92 | ]; 93 | }; 94 | in reflex-platform.${ghc}.reflex); 95 | in variationPkgs // { 96 | cache = reflex-platform.pinBuildInputs "reflex-${system}-${ghc}" 97 | (builtins.attrValues variationPkgs); 98 | }); 99 | in compilerPkgs // nixpkgsGhcs // { 100 | cache = reflex-platform.pinBuildInputs "reflex-${system}" 101 | (map (a: a.cache) (builtins.attrValues compilerPkgs)); 102 | }); 103 | 104 | metaCache = native-reflex-platform.pinBuildInputs "reflex-everywhere" 105 | (map (a: a.cache) (builtins.attrValues perPlatform)); 106 | 107 | in perPlatform // { inherit metaCache; } 108 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | # Enter a shell for this project, with some choice of compiler. By default, we 2 | # select the version of ghc provided by reflex-platform, but you can choose a 3 | # later version from nixpkgs as well by doing: 4 | # $ nix-shell --argstr compiler "ghc943" 5 | { compiler ? "reflex-platform" # or "ghc943", "ghc924" 6 | }: 7 | let 8 | rp = import ./dep/reflex-platform { __useNewerCompiler = true; }; 9 | pkgs = rp.nixpkgs; 10 | haskellLib = pkgs.haskell.lib; 11 | system = builtins.currentSystem; 12 | nixpkgsGhc = ((import ./nixpkgs {}).haskell.packages.${compiler}).override { 13 | overrides = self: super: import ./overlay.nix { inherit self super haskellLib; } // { 14 | hlint = self.callHackageDirect { 15 | pkg = "hlint"; 16 | ver = "3.5"; 17 | sha256 = "1np43k54918v54saqqgnd82ccd6225njwxpg2031asi70jam80x9"; 18 | } {}; 19 | }; 20 | }; 21 | reflexEnv = if compiler == "reflex-platform" 22 | then (import ./release.nix {}).${system}.ghc.reflex.env 23 | else (nixpkgsGhc.callCabal2nix "reflex" (import ./src.nix) {}).env; 24 | in 25 | pkgs.mkShell { 26 | name = "shell"; 27 | buildInputs = [ 28 | pkgs.cabal-install 29 | pkgs.ghcid 30 | ]; 31 | inputsFrom = [ 32 | reflexEnv 33 | ]; 34 | } 35 | -------------------------------------------------------------------------------- /src.nix: -------------------------------------------------------------------------------- 1 | builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ 2 | "release.nix" 3 | ".git" 4 | "dist" 5 | "cabal.haskell-ci" 6 | "cabal.project" 7 | ".travis.yml" 8 | ])) ./. 9 | -------------------------------------------------------------------------------- /src/Control/Monad/ReaderIO.hs: -------------------------------------------------------------------------------- 1 | {-# language RoleAnnotations #-} 2 | {-# language MultiParamTypeClasses #-} 3 | {-# language FlexibleInstances #-} 4 | {-# language CPP #-} 5 | module Control.Monad.ReaderIO 6 | ( 7 | ReaderIO (..) 8 | ) 9 | where 10 | 11 | import Control.Monad.Fix 12 | import Control.Applicative 13 | import Control.Monad 14 | import Control.Monad.Reader.Class 15 | import Control.Monad.IO.Class 16 | 17 | -- | An approximate clone of @RIO@ from the @rio@ package, but not based on 18 | -- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a 19 | -- @nominal@ role, so we can't coerce through it when it's wrapped in some 20 | -- other @data@ type. Ugh. 21 | newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a } 22 | type role ReaderIO representational representational 23 | 24 | instance Functor (ReaderIO e) where 25 | fmap = liftM 26 | {-# INLINE fmap #-} 27 | a <$ m = m >> pure a 28 | {-# INLINE (<$) #-} 29 | 30 | instance Applicative (ReaderIO e) where 31 | pure a = ReaderIO $ \_ -> pure a 32 | {-# INLINE pure #-} 33 | (<*>) = ap 34 | {-# INLINE (<*>) #-} 35 | liftA2 = liftM2 36 | {-# INLINE liftA2 #-} 37 | 38 | instance Monad (ReaderIO e) where 39 | ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e 40 | {-# INLINE (>>=) #-} 41 | 42 | instance MonadFix (ReaderIO e) where 43 | mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e 44 | {-# INLINE mfix #-} 45 | 46 | instance MonadIO (ReaderIO e) where 47 | liftIO m = ReaderIO $ \_ -> m 48 | {-# INLINE liftIO #-} 49 | 50 | instance MonadReader e (ReaderIO e) where 51 | ask = ReaderIO pure 52 | {-# INLINE ask #-} 53 | local f (ReaderIO m) = ReaderIO (m . f) 54 | {-# INLINE local #-} 55 | -------------------------------------------------------------------------------- /src/Data/AppendMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE RoleAnnotations #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# OPTIONS_GHC -fno-warn-orphans #-} 10 | -- | 11 | -- Module: 12 | -- Data.AppendMap 13 | -- Description: 14 | -- Instances and convenience functions for 'Data.Map.Monoidal'. We use 15 | -- monoidal-containers to take advantage of its better monoid instance. 16 | -- 'Data.Map' has @mappend = union@, which is left-biased. 'MonoidalMap' 17 | -- has @mappend = unionWith mappend@ instead. 18 | module Data.AppendMap 19 | ( module Data.AppendMap 20 | , module Data.Map.Monoidal 21 | ) where 22 | 23 | import Prelude hiding (null) 24 | 25 | import Data.Coerce 26 | import Data.Default 27 | import Data.Map (Map) 28 | import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) 29 | 30 | import Data.Map.Monoidal 31 | 32 | 33 | {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} 34 | -- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap' 35 | type AppendMap = MonoidalMap 36 | 37 | {-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-} 38 | -- | A synonym for 'getMonoidalMap' 39 | _unAppendMap :: MonoidalMap k v -> Map k v 40 | _unAppendMap = getMonoidalMap 41 | 42 | -- | Pattern synonym for 'MonoidalMap' 43 | pattern AppendMap :: Map k v -> MonoidalMap k v 44 | pattern AppendMap m = MonoidalMap m 45 | 46 | -- | Deletes a key, returning 'Nothing' if the result is empty. 47 | nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) 48 | nonEmptyDelete k vs = 49 | let deleted = delete k vs 50 | in if null deleted 51 | then Nothing 52 | else Just deleted 53 | 54 | -- | Like 'mapMaybe' but indicates whether the resulting container is empty 55 | mapMaybeNoNull :: (a -> Maybe b) 56 | -> MonoidalMap token a 57 | -> Maybe (MonoidalMap token b) 58 | mapMaybeNoNull f as = 59 | let bs = mapMaybe f as 60 | in if null bs 61 | then Nothing 62 | else Just bs 63 | 64 | -- TODO: Move instances to `Data.Patch` 65 | -- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details. 66 | showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String 67 | showTree = coerce (Map.showTree :: Map k a -> String) 68 | 69 | -- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string. 70 | showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String 71 | showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String) 72 | 73 | instance Default (MonoidalMap k a) where 74 | def = empty 75 | -------------------------------------------------------------------------------- /src/Data/FastMutableIntMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | -- | 3 | -- Module: 4 | -- Data.FastMutableIntMap 5 | -- Description: 6 | -- A mutable version of 'IntMap' 7 | module Data.FastMutableIntMap 8 | ( FastMutableIntMap 9 | , new 10 | , newEmpty 11 | , insert 12 | , isEmpty 13 | , getFrozenAndClear 14 | , size 15 | , applyPatch 16 | , PatchIntMap (..) 17 | , traverseIntMapPatchWithKey 18 | , lookup 19 | , forIntersectionWithImmutable_ 20 | , for_ 21 | , patchIntMapNewElements 22 | , patchIntMapNewElementsMap 23 | , getDeletions 24 | , toList 25 | ) where 26 | 27 | --TODO: Pure JS version 28 | --TODO: Fast copy to FastIntMap 29 | --TODO: Fast patch type 30 | 31 | import Prelude hiding (lookup) 32 | 33 | import Control.Monad.IO.Class 34 | import Data.Foldable (traverse_) 35 | import Data.IntMap.Strict (IntMap) 36 | import qualified Data.IntMap.Strict as IntMap 37 | import Data.IORef 38 | import Data.Patch.Class 39 | import Data.Patch.IntMap 40 | 41 | -- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO. 42 | -- Operations on 'FastMutableIntMap' run in IO. 43 | newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a)) 44 | 45 | -- | Create a new 'FastMutableIntMap' out of an 'IntMap' 46 | new :: IntMap a -> IO (FastMutableIntMap a) 47 | new m = FastMutableIntMap <$> newIORef m 48 | 49 | -- | Create a new empty 'FastMutableIntMap' 50 | newEmpty :: IO (FastMutableIntMap a) 51 | newEmpty = FastMutableIntMap <$> newIORef IntMap.empty 52 | 53 | -- | Insert an element into a 'FastMutableIntMap' at the given key 54 | insert :: FastMutableIntMap a -> Int -> a -> IO () 55 | insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v 56 | 57 | -- | Attempt to lookup an element by key in a 'FastMutableIntMap' 58 | lookup :: FastMutableIntMap a -> Int -> IO (Maybe a) 59 | lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r 60 | 61 | -- | Runs the provided action over the intersection of a 'FastMutableIntMap' and an 'IntMap' 62 | forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m () 63 | forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do 64 | a <- liftIO $ readIORef r 65 | traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b 66 | 67 | -- | Runs the provided action over the values of a 'FastMutableIntMap' 68 | for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m () 69 | for_ (FastMutableIntMap r) f = do 70 | a <- liftIO $ readIORef r 71 | traverse_ f a 72 | 73 | -- | Checks whether a 'FastMutableIntMap' is empty 74 | isEmpty :: FastMutableIntMap a -> IO Bool 75 | isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r 76 | 77 | -- | Retrieves the size of a 'FastMutableIntMap' 78 | size :: FastMutableIntMap a -> IO Int 79 | size (FastMutableIntMap r) = IntMap.size <$> readIORef r 80 | 81 | -- | Make an immutable snapshot of the datastructure and clear it 82 | getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a) 83 | getFrozenAndClear (FastMutableIntMap r) = do 84 | result <- readIORef r 85 | writeIORef r IntMap.empty 86 | return result 87 | 88 | -- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'), 89 | -- and returns an 'IntMap' with the modified keys and values. 90 | applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a) 91 | applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do 92 | v <- readIORef r 93 | writeIORef r $! applyAlways p v 94 | return $ IntMap.intersection v m 95 | 96 | toList :: FastMutableIntMap a -> IO [(Int, a)] 97 | toList (FastMutableIntMap r) = IntMap.toList <$> readIORef r -------------------------------------------------------------------------------- /src/Data/FastWeakBag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | #ifdef USE_REFLEX_OPTIMIZER 4 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 5 | #endif 6 | #ifdef GHCJS_FAST_WEAK 7 | {-# LANGUAGE ForeignFunctionInterface #-} 8 | {-# LANGUAGE JavaScriptFFI #-} 9 | #endif 10 | -- | This module defines the 'FastWeakBag' type, which represents a mutable 11 | -- collection of items that does not cause the items to be retained in memory. 12 | -- This is useful for situations where a value needs to be inspected or modified 13 | -- if it is still alive, but can be ignored if it is dead. 14 | module Data.FastWeakBag 15 | ( FastWeakBag 16 | , FastWeakBagTicket 17 | , empty 18 | , isEmpty 19 | , insert 20 | , traverse 21 | , traverse_ 22 | , remove 23 | -- * Internal functions 24 | -- These will not always be available. 25 | #ifndef GHCJS_FAST_WEAK 26 | , _weakBag_children --TODO: Don't export this 27 | #endif 28 | ) where 29 | 30 | import Prelude hiding (traverse) 31 | 32 | import Control.Monad 33 | import Control.Monad.IO.Class 34 | 35 | #ifdef GHCJS_FAST_WEAK 36 | import GHCJS.Types 37 | import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal) 38 | #else 39 | import Control.Exception 40 | import Data.IntMap.Strict (IntMap) 41 | import qualified Data.IntMap.Strict as IntMap 42 | import Data.IORef 43 | import System.Mem.Weak 44 | #endif 45 | 46 | -- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them - 47 | -- that is, they can still be garbage-collected. As long as the @/a/@ values remain 48 | -- alive, the 'FastWeakBag' will continue to refer to them. 49 | #ifdef GHCJS_FAST_WEAK 50 | newtype FastWeakBag a = FastWeakBag JSVal 51 | #else 52 | data FastWeakBag a = FastWeakBag 53 | { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? 54 | , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag' 55 | } 56 | #endif 57 | 58 | -- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If 59 | -- the caller retains the ticket, the item is guranteed to stay in memory (and 60 | -- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from 61 | -- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'. 62 | #ifdef GHCJS_FAST_WEAK 63 | newtype FastWeakBagTicket a = FastWeakBagTicket JSVal 64 | #else 65 | data FastWeakBagTicket a = FastWeakBagTicket 66 | { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a) 67 | , _weakBagTicket_item :: {-# NOUNPACK #-} !a 68 | } 69 | #endif 70 | 71 | -- | Insert an item into a 'FastWeakBag'. 72 | {-# INLINE insert #-} 73 | insert :: a -- ^ The item 74 | -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into 75 | -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item 76 | -- is retained and allows the item to be removed. 77 | #ifdef GHCJS_FAST_WEAK 78 | insert a wb = js_insert (unsafeToRawJSVal a) wb 79 | foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a) 80 | #else 81 | insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do 82 | a' <- evaluate a 83 | myId <- atomicModifyIORef' nextId $ \n -> (succ n, n) 84 | let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ()) 85 | wa <- mkWeakPtr a' $ Just cleanup 86 | atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ()) 87 | return $ FastWeakBagTicket 88 | { _weakBagTicket_weakItem = wa 89 | , _weakBagTicket_item = a' 90 | } 91 | #endif 92 | 93 | -- | Create an empty 'FastWeakBag'. 94 | {-# INLINE empty #-} 95 | empty :: IO (FastWeakBag a) 96 | #ifdef GHCJS_FAST_WEAK 97 | empty = js_empty 98 | foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a) 99 | #else 100 | empty = {-# SCC "empty" #-} do 101 | nextId <- newIORef 1 102 | children <- newIORef IntMap.empty 103 | let bag = FastWeakBag 104 | { _weakBag_nextId = nextId 105 | , _weakBag_children = children 106 | } 107 | return bag 108 | #endif 109 | 110 | -- | Check whether a 'FastWeakBag' is empty. 111 | {-# INLINE isEmpty #-} 112 | isEmpty :: FastWeakBag a -> IO Bool 113 | #ifdef GHCJS_FAST_WEAK 114 | isEmpty = js_isEmpty 115 | foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time 116 | #else 117 | isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag) 118 | #endif 119 | 120 | {-# INLINE traverse_ #-} 121 | -- | Visit every node in the given list. If new nodes are appended during the 122 | -- traversal, they will not be visited. Every live node that was in the list 123 | -- when the traversal began will be visited exactly once; however, no guarantee 124 | -- is made about the order of the traversal. 125 | traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () 126 | #ifdef GHCJS_FAST_WEAK 127 | traverse_ wb f = do 128 | let go cursor = when (not $ js_isNull cursor) $ do 129 | val <- liftIO $ js_getTicketValue cursor 130 | f $ unsafeFromRawJSVal val 131 | go =<< liftIO (js_getNext (FastWeakBagTicket cursor)) 132 | go =<< liftIO (js_getInitial wb) 133 | foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a 134 | foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal 135 | --TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag 136 | foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a 137 | #else 138 | traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do 139 | cs <- liftIO $ readIORef children 140 | forM_ cs $ \c -> do 141 | ma <- liftIO $ deRefWeak c 142 | mapM_ f ma 143 | #endif 144 | 145 | {-# DEPRECATED traverse "Use 'traverse_' instead" #-} 146 | traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () 147 | traverse = traverse_ 148 | 149 | -- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times 150 | -- on the same 'FastWeakBagTicket'. 151 | {-# INLINE remove #-} 152 | remove :: FastWeakBagTicket a -> IO () 153 | #ifdef GHCJS_FAST_WEAK 154 | remove = js_remove 155 | foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here 156 | #else 157 | remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w 158 | #endif 159 | --TODO: Should 'remove' also drop the reference to the item? 160 | 161 | --TODO: can/should we provide a null FastWeakBagTicket? 162 | -------------------------------------------------------------------------------- /src/Data/Map/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | -- | Additional functions for manipulating 'Map's. 3 | module Data.Map.Misc 4 | ( 5 | -- * Working with Maps 6 | diffMapNoEq 7 | , diffMap 8 | , applyMap 9 | , mapPartitionEithers 10 | , applyMapKeysSet 11 | ) where 12 | 13 | import Data.Align 14 | import Data.Map (Map) 15 | import qualified Data.Map as Map 16 | import Data.Maybe 17 | import Data.Set (Set) 18 | import qualified Data.Set as Set 19 | import Data.These 20 | 21 | -- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@ 22 | -- represents an association only present in @old@ but no longer present in @new@. 23 | -- 24 | -- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not. 25 | diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v) 26 | diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case 27 | This _ -> Just Nothing 28 | These _ new -> Just $ Just new 29 | That new -> Just $ Just new 30 | 31 | -- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not 32 | -- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@. 33 | -- 34 | -- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between 35 | -- @old@ and @new@ with @Nothing@. 36 | diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v) 37 | diffMap olds news = flip Map.mapMaybe (align olds news) $ \case 38 | This _ -> Just Nothing 39 | These old new 40 | | old == new -> Nothing 41 | | otherwise -> Just $ Just new 42 | That new -> Just $ Just new 43 | 44 | -- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@. 45 | -- 46 | -- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'. 47 | applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v 48 | applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) 49 | where (deletions, insertions) = Map.mapEither maybeToEither patch 50 | maybeToEither = \case 51 | Nothing -> Left () 52 | Just r -> Right r 53 | 54 | -- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@ 55 | {-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-} 56 | mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b) 57 | mapPartitionEithers = Map.mapEither id 58 | 59 | -- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new @'Set' k@ from the given input set. 60 | -- 61 | -- Equivalent to: 62 | -- 63 | -- @ 64 | -- applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m) 65 | -- @ 66 | -- 67 | -- but avoids the intervening @Map@ and needs no values. 68 | applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k 69 | applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions) 70 | where (insertions, deletions) = Map.partition isJust patch 71 | 72 | -------------------------------------------------------------------------------- /src/Data/WeakBag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | #ifdef USE_REFLEX_OPTIMIZER 5 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 6 | #endif 7 | -- | This module defines the 'WeakBag' type, which represents a mutable 8 | -- collection of items that does not cause the items to be retained in memory. 9 | -- This is useful for situations where a value needs to be inspected or modified 10 | -- if it is still alive, but can be ignored if it is dead. 11 | module Data.WeakBag 12 | ( WeakBag 13 | , WeakBagTicket 14 | , empty 15 | , singleton 16 | , insert 17 | , traverse 18 | , traverse_ 19 | , remove 20 | -- * Internal functions 21 | -- These will not always be available. 22 | , _weakBag_children --TODO: Don't export this 23 | ) where 24 | 25 | import Prelude hiding (traverse) 26 | 27 | import Control.Exception 28 | import Control.Monad 29 | import Control.Monad.IO.Class 30 | import Data.IntMap.Strict (IntMap) 31 | import qualified Data.IntMap.Strict as IntMap 32 | import Data.IORef 33 | import System.Mem.Weak 34 | 35 | -- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them - 36 | -- that is, they can still be garbage-collected. As long as the @/a/@ values remain 37 | -- alive, the 'WeakBag' will continue to refer to them. 38 | data WeakBag a = WeakBag 39 | { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? 40 | , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ The items referenced by the WeakBag 41 | } 42 | 43 | -- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned. If 44 | -- the caller retains the ticket, the item is guranteed to stay in memory (and 45 | -- thus in the 'WeakBag'). The ticket can also be used to remove the item from 46 | -- the 'WeakBag' prematurely (i.e. while it is still alive), using 'remove'. 47 | data WeakBagTicket = forall a. WeakBagTicket 48 | { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a) 49 | , _weakBagTicket_item :: {-# NOUNPACK #-} !a 50 | } 51 | 52 | -- | Insert an item into a 'WeakBag'. 53 | {-# INLINE insert #-} 54 | insert :: a -- ^ The item 55 | -> WeakBag a -- ^ The 'WeakBag' to insert into 56 | -> IORef (Weak b) -- ^ An arbitrary value to be used in the following 57 | -- callback 58 | -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed 59 | -- (whether automatically by the item being garbage 60 | -- collected or manually via 'remove') 61 | -> IO WeakBagTicket -- ^ Returns a 'WeakBagTicket' that ensures the item 62 | -- is retained and allows the item to be removed. 63 | insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do 64 | a' <- evaluate a 65 | wbRef' <- evaluate wbRef 66 | myId <- atomicModifyIORef' nextId $ \n -> (succ n, n) 67 | let cleanup = do 68 | wb <- readIORef wbRef' 69 | mb <- deRefWeak wb 70 | forM_ mb $ \b -> do 71 | csWithoutMe <- atomicModifyIORef children $ \cs -> 72 | let !csWithoutMe = IntMap.delete myId cs 73 | in (csWithoutMe, csWithoutMe) 74 | when (IntMap.null csWithoutMe) $ finalizer b 75 | wa <- mkWeakPtr a' $ Just cleanup 76 | atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ()) 77 | return $ WeakBagTicket 78 | { _weakBagTicket_weakItem = wa 79 | , _weakBagTicket_item = a' 80 | } 81 | 82 | -- | Create an empty 'WeakBag'. 83 | {-# INLINE empty #-} 84 | empty :: IO (WeakBag a) 85 | empty = {-# SCC "empty" #-} do 86 | nextId <- newIORef 1 87 | children <- newIORef IntMap.empty 88 | let bag = WeakBag 89 | { _weakBag_nextId = nextId 90 | , _weakBag_children = children 91 | } 92 | return bag 93 | 94 | -- | Create a 'WeakBag' with one item; equivalent to creating the 'WeakBag' with 95 | -- 'empty', then using 'insert'. 96 | {-# INLINE singleton #-} 97 | singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket) 98 | singleton a wbRef finalizer = {-# SCC "singleton" #-} do 99 | bag <- empty 100 | ticket <- insert a bag wbRef finalizer 101 | return (bag, ticket) 102 | 103 | {-# INLINE traverse_ #-} 104 | -- | Visit every node in the given list. If new nodes are appended during the 105 | -- traversal, they will not be visited. Every live node that was in the list 106 | -- when the traversal began will be visited exactly once; however, no guarantee 107 | -- is made about the order of the traversal. 108 | traverse_ :: MonadIO m => WeakBag a -> (a -> m ()) -> m () 109 | traverse_ (WeakBag _ children) f = {-# SCC "traverse" #-} do 110 | cs <- liftIO $ readIORef children 111 | forM_ cs $ \c -> do 112 | ma <- liftIO $ deRefWeak c 113 | mapM_ f ma 114 | 115 | {-# DEPRECATED traverse "Use 'traverse_' instead" #-} 116 | traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m () 117 | traverse = traverse_ 118 | 119 | -- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times 120 | -- on the same 'WeakBagTicket'. 121 | {-# INLINE remove #-} 122 | remove :: WeakBagTicket -> IO () 123 | remove (WeakBagTicket w _) = {-# SCC "remove" #-} finalize w 124 | --TODO: Should 'remove' also drop the reference to the item? 125 | 126 | --TODO: can/should we provide a null WeakBagTicket? 127 | -------------------------------------------------------------------------------- /src/Reflex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | This module exports all of the commonly-used functionality of Reflex; if 3 | -- you are just getting started with Reflex, this is probably what you want. 4 | module Reflex 5 | ( module X 6 | ) where 7 | 8 | import Reflex.Class as X 9 | import Reflex.Adjustable.Class as X 10 | import Reflex.BehaviorWriter.Base as X 11 | import Reflex.BehaviorWriter.Class as X 12 | import Reflex.Collection as X 13 | import Reflex.Dynamic as X 14 | import Reflex.EventWriter.Base as X 15 | import Reflex.EventWriter.Class as X 16 | #ifdef USE_TEMPLATE_HASKELL 17 | import Reflex.Dynamic.TH as X 18 | #endif 19 | import Reflex.Dynamic.Uniq as X 20 | import Reflex.DynamicWriter.Base as X 21 | import Reflex.DynamicWriter.Class as X 22 | import Reflex.NotReady.Class as X 23 | import Reflex.PerformEvent.Base as X 24 | import Reflex.PerformEvent.Class as X 25 | import Reflex.PostBuild.Base as X 26 | import Reflex.PostBuild.Class as X 27 | import Reflex.Profiled as X 28 | import Reflex.Query.Base as X 29 | import Reflex.Query.Class as X 30 | import Reflex.Requester.Base as X 31 | import Reflex.Requester.Class as X 32 | import Reflex.Spider as X 33 | import Reflex.Time as X 34 | import Reflex.TriggerEvent.Base as X 35 | import Reflex.TriggerEvent.Class as X 36 | -------------------------------------------------------------------------------- /src/Reflex/Adjustable/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | #ifdef USE_REFLEX_OPTIMIZER 11 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 12 | #endif 13 | -- | 14 | -- Module: 15 | -- Reflex.Adjustable.Class 16 | -- Description: 17 | -- A class for actions that can be "adjusted" over time based on some 'Event' 18 | -- such that, when observed after the firing of any such 'Event', the result 19 | -- is as though the action was originally run with the 'Event's value. 20 | module Reflex.Adjustable.Class 21 | ( 22 | -- * The Adjustable typeclass 23 | Adjustable(..) 24 | , sequenceDMapWithAdjust 25 | , sequenceDMapWithAdjustWithMove 26 | , mapMapWithAdjustWithMove 27 | -- * Deprecated aliases 28 | , MonadAdjust 29 | ) where 30 | 31 | import Control.Monad.Identity 32 | import Control.Monad.Reader 33 | import Data.Dependent.Map (DMap) 34 | import Data.GADT.Compare (GCompare(..)) 35 | import qualified Data.Dependent.Map as DMap 36 | import Data.Functor.Constant 37 | import Data.Functor.Misc 38 | import Data.IntMap.Strict (IntMap) 39 | import qualified Data.IntMap.Strict as IntMap 40 | import Data.Map (Map) 41 | 42 | import Reflex.Class 43 | import Data.Patch.DMapWithMove 44 | 45 | -- | A 'Monad' that supports adjustment over time. After an action has been 46 | -- run, if the given events fire, it will adjust itself so that its net effect 47 | -- is as though it had originally been run with the new value. Note that there 48 | -- is some issue here with persistent side-effects: obviously, IO (and some 49 | -- other side-effects) cannot be undone, so it is up to the instance implementer 50 | -- to determine what the best meaning for this class is in such cases. 51 | class (Reflex t, Monad m) => Adjustable t m | m -> t where 52 | runWithReplace 53 | :: m a 54 | -> Event t (m b) 55 | -> m (a, Event t b) 56 | 57 | traverseIntMapWithKeyWithAdjust 58 | :: (IntMap.Key -> v -> m v') 59 | -> IntMap v 60 | -> Event t (PatchIntMap v) 61 | -> m (IntMap v', Event t (PatchIntMap v')) 62 | 63 | traverseDMapWithKeyWithAdjust 64 | :: GCompare k 65 | => (forall a. k a -> v a -> m (v' a)) 66 | -> DMap k v 67 | -> Event t (PatchDMap k v) 68 | -> m (DMap k v', Event t (PatchDMap k v')) 69 | {-# INLINABLE traverseDMapWithKeyWithAdjust #-} 70 | traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $ 71 | traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm' 72 | where 73 | toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m 74 | toNodeInfoWithMove = \case 75 | ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing 76 | ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing 77 | fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m 78 | fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of 79 | From_Insert v -> Just v 80 | From_Delete -> Nothing 81 | From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move" 82 | 83 | traverseDMapWithKeyWithAdjustWithMove 84 | :: GCompare k 85 | => (forall a. k a -> v a -> m (v' a)) 86 | -> DMap k v 87 | -> Event t (PatchDMapWithMove k v) 88 | -> m (DMap k v', Event t (PatchDMapWithMove k v')) 89 | 90 | instance Adjustable t m => Adjustable t (ReaderT r m) where 91 | runWithReplace a0 a' = do 92 | r <- ask 93 | lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a' 94 | traverseIntMapWithKeyWithAdjust f dm0 dm' = do 95 | r <- ask 96 | lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm' 97 | traverseDMapWithKeyWithAdjust f dm0 dm' = do 98 | r <- ask 99 | lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm' 100 | traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do 101 | r <- ask 102 | lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm' 103 | 104 | -- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches 105 | -- to the 'DMap' can add, remove, or update values. 106 | sequenceDMapWithAdjust 107 | :: (GCompare k, Adjustable t m) 108 | => DMap k m 109 | -> Event t (PatchDMap k m) 110 | -> m (DMap k Identity, Event t (PatchDMap k Identity)) 111 | sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity 112 | 113 | -- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches 114 | -- to the 'DMap' can add, remove, update, move, or swap values. 115 | sequenceDMapWithAdjustWithMove 116 | :: (GCompare k, Adjustable t m) 117 | => DMap k m 118 | -> Event t (PatchDMapWithMove k m) 119 | -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity)) 120 | sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity 121 | 122 | -- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map' 123 | -- can add, remove, update, move, or swap values. 124 | mapMapWithAdjustWithMove 125 | :: forall t m k v v'. (Adjustable t m, Ord k) 126 | => (k -> v -> m v') 127 | -> Map k v 128 | -> Event t (PatchMapWithMove k v) 129 | -> m (Map k v', Event t (PatchMapWithMove k v')) 130 | mapMapWithAdjustWithMove f m0 m' = do 131 | (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m') 132 | return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out') 133 | 134 | -------------------------------------------------------------------------------- 135 | -- Deprecated functions 136 | -------------------------------------------------------------------------------- 137 | 138 | {-# DEPRECATED MonadAdjust "Use Adjustable instead" #-} 139 | -- | Synonym for 'Adjustable' 140 | type MonadAdjust = Adjustable 141 | -------------------------------------------------------------------------------- /src/Reflex/BehaviorWriter/Class.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Reflex.BehaviorWriter.Class 3 | Description: This module defines the 'BehaviorWriter' class 4 | -} 5 | {-# LANGUAGE CPP #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | #ifdef USE_REFLEX_OPTIMIZER 11 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 12 | #endif 13 | module Reflex.BehaviorWriter.Class 14 | ( MonadBehaviorWriter 15 | , BehaviorWriter(..) 16 | ) where 17 | 18 | import Control.Monad.Reader (ReaderT, lift) 19 | import Reflex.Class (Behavior) 20 | 21 | {-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-} 22 | -- | Type synonym for 'BehaviorWriter' 23 | type MonadBehaviorWriter = BehaviorWriter 24 | 25 | -- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior' 26 | -- and combines them monoidally to provide a 'Behavior' result. 27 | class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where 28 | tellBehavior :: Behavior t w -> m () 29 | 30 | instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where 31 | tellBehavior = lift . tellBehavior 32 | -------------------------------------------------------------------------------- /src/Reflex/Dynamic/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PatternGuards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | #ifdef USE_REFLEX_OPTIMIZER 9 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 10 | #endif 11 | -- | Template Haskell helper functions for building complex 'Dynamic' values. 12 | module Reflex.Dynamic.TH 13 | ( qDynPure 14 | , unqDyn 15 | , mkDynPure 16 | ) where 17 | 18 | import Reflex.Dynamic 19 | 20 | import Control.Monad.State 21 | import Data.Data 22 | import Data.Generics 23 | import qualified Language.Haskell.Exts as Hs 24 | import qualified Language.Haskell.Meta.Syntax.Translate as Hs 25 | import Language.Haskell.TH 26 | import Language.Haskell.TH.Quote 27 | import qualified Language.Haskell.TH.Syntax as TH 28 | 29 | -- | Quote a 'Dynamic' expression. Within the quoted expression, you can use 30 | -- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the 31 | -- unquoted result will be of type @a@ 32 | qDynPure :: Q Exp -> Q Exp 33 | qDynPure qe = do 34 | e <- qe 35 | let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d 36 | f d = case eqT of 37 | Just (Refl :: d :~: Exp) 38 | | AppE (VarE m) eInner <- d 39 | , m == 'unqMarker 40 | -> do n <- lift $ newName "dynamicQuotedExpressionVariable" 41 | modify ((n, eInner):) 42 | return $ VarE n 43 | _ -> gmapM f d 44 | (e', exprsReversed) <- runStateT (gmapM f e) [] 45 | let exprs = reverse exprsReversed 46 | arg = foldr 47 | (\(_, expr) rest -> [e| FHCons $(pure expr) $rest |]) 48 | [e| FHNil |] 49 | exprs 50 | param = foldr 51 | (\(name, _) rest -> [p| HCons $(pure $ VarP name) $rest |]) 52 | [p| HNil |] 53 | exprs 54 | [| (\ $param -> $(pure e')) <$> distributeFHListOverDynPure $arg |] 55 | 56 | -- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a 57 | -- 'qDyn' quotation. 58 | unqDyn :: Q Exp -> Q Exp 59 | unqDyn e = [| unqMarker $e |] 60 | 61 | -- | This type represents an occurrence of unqDyn before it has been processed 62 | -- by qDyn. If you see it in a type error, it probably means that unqDyn has 63 | -- been used outside of a qDyn context. 64 | data UnqDyn 65 | 66 | -- unqMarker must not be exported; it is used only as a way of smuggling data 67 | -- from unqDyn to qDyn 68 | 69 | --TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery 70 | unqMarker :: a -> UnqDyn 71 | unqMarker = error "An unqDyn expression was used outside of a qDyn expression" 72 | 73 | -- | Create a 'Dynamic' value using other 'Dynamic's as inputs. The result is 74 | -- sometimes more concise and readable than the equivalent 'Applicative'-based 75 | -- expression. For example: 76 | -- 77 | -- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |] 78 | -- 79 | -- would have a very cumbersome 'Applicative' encoding. 80 | mkDynPure :: QuasiQuoter 81 | mkDynPure = QuasiQuoter 82 | { quoteExp = mkDynExp 83 | , quotePat = error "mkDyn: pattern splices are not supported" 84 | , quoteType = error "mkDyn: type splices are not supported" 85 | , quoteDec = error "mkDyn: declaration splices are not supported" 86 | } 87 | 88 | mkDynExp :: String -> Q Exp 89 | mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of 90 | Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err 91 | Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e 92 | where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker 93 | antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo 94 | antiE x = case x of 95 | Hs.SpliceExp l se -> 96 | Hs.App l (Hs.Var l $ Hs.Qual l (Hs.ModuleName l modName) (Hs.Ident l occName)) $ case se of 97 | Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v 98 | Hs.ParenSplice _ ps -> ps 99 | _ -> x 100 | reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName'))) 101 | | modName == modName' && occName == occName' = 'unqMarker 102 | reinstateUnqDyn x = x 103 | -------------------------------------------------------------------------------- /src/Reflex/Dynamic/Uniq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | #ifdef USE_REFLEX_OPTIMIZER 6 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 7 | #endif 8 | -- | This module provides a variation of 'Dynamic' values that uses cheap 9 | -- pointer equality checks to reduce the amount of signal propagation needed. 10 | module Reflex.Dynamic.Uniq 11 | ( UniqDynamic 12 | , uniqDynamic 13 | , fromUniqDynamic 14 | , alreadyUniqDynamic 15 | ) where 16 | 17 | import GHC.Exts 18 | import Reflex.Class 19 | 20 | -- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as 21 | -- the 'current' 'Behavior''s contents. In order to maintain this constraint, 22 | -- the value inside a 'UniqDynamic' is always evaluated to 23 | -- . 24 | -- 25 | -- Internally, 'UniqDynamic' uses pointer equality as a heuristic to avoid 26 | -- unnecessary update propagation; this is much more efficient than performing 27 | -- full comparisons. However, when the 'UniqDynamic' is converted back into a 28 | -- regular 'Dynamic', a full comparison is performed. 29 | newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a } 30 | 31 | -- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'. 32 | uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a 33 | uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do 34 | old <- sample $ current d --TODO: Is it better to sample ourselves here? 35 | return $ unsafeJustChanged old new 36 | 37 | -- | Retrieve a normal 'Dynamic' from a 'UniqDynamic'. This will perform a 38 | -- final check using the output type's 'Eq' instance to ensure deterministic 39 | -- behavior. 40 | -- 41 | -- WARNING: If used with a type whose 'Eq' instance is not law-abiding - 42 | -- specifically, if there are cases where @x /= x@, 'fromUniqDynamic' may 43 | -- eliminate more 'updated' occurrences than it should. For example, NaN values 44 | -- of 'Double' and 'Float' are considered unequal to themselves by the 'Eq' 45 | -- instance, but can be equal by pointer equality. This may cause 'UniqDynamic' 46 | -- to lose changes from NaN to NaN. 47 | fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a 48 | fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e' 49 | where 50 | -- Only consider values different if they fail both pointer equality /and/ 51 | -- 'Eq' equality. This is to make things a bit more deterministic in the 52 | -- case of unlawful 'Eq' instances. However, it is still possible to 53 | -- achieve nondeterminism by constructing elements that are identical in 54 | -- value, unequal according to 'Eq', and nondeterministically equal or 55 | -- nonequal by pointer quality. I suspect that it is impossible to make the 56 | -- behavior deterministic in this case. 57 | superEq a b = a `unsafePtrEq` b || a == b 58 | e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d) 59 | 60 | -- | Create a UniqDynamic without uniqing it on creation. This will be slightly 61 | -- faster than uniqDynamic when used with a Dynamic whose values are always (or 62 | -- nearly always) different from its previous values; if used with a Dynamic 63 | -- whose values do not change frequently, it may be much slower than uniqDynamic 64 | alreadyUniqDynamic :: Dynamic t a -> UniqDynamic t a 65 | alreadyUniqDynamic = UniqDynamic 66 | 67 | unsafePtrEq :: a -> a -> Bool 68 | unsafePtrEq a b = case a `seq` b `seq` reallyUnsafePtrEquality# a b of 69 | 0# -> False 70 | _ -> True 71 | 72 | unsafeJustChanged :: a -> a -> Maybe a 73 | unsafeJustChanged old new = 74 | if old `unsafePtrEq` new 75 | then Nothing 76 | else Just new 77 | 78 | instance Reflex t => Accumulator t (UniqDynamic t) where 79 | accumMaybeM f z e = do 80 | let f' old change = do 81 | mNew <- f old change 82 | return $ unsafeJustChanged old =<< mNew 83 | d <- accumMaybeMDyn f' z e 84 | return $ UniqDynamic d 85 | mapAccumMaybeM f z e = do 86 | let f' old change = do 87 | (mNew, output) <- f old change 88 | return (unsafeJustChanged old =<< mNew, output) 89 | (d, out) <- mapAccumMaybeMDyn f' z e 90 | return (UniqDynamic d, out) 91 | 92 | instance Reflex t => Functor (UniqDynamic t) where 93 | fmap f (UniqDynamic d) = uniqDynamic $ fmap f d 94 | 95 | instance Reflex t => Applicative (UniqDynamic t) where 96 | pure = UniqDynamic . constDyn 97 | UniqDynamic a <*> UniqDynamic b = uniqDynamic $ a <*> b 98 | _ *> b = b 99 | a <* _ = a 100 | 101 | instance Reflex t => Monad (UniqDynamic t) where 102 | UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f 103 | -------------------------------------------------------------------------------- /src/Reflex/DynamicWriter.hs: -------------------------------------------------------------------------------- 1 | module Reflex.DynamicWriter 2 | {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-} 3 | ( module X 4 | ) where 5 | 6 | import Reflex.DynamicWriter.Base as X 7 | import Reflex.DynamicWriter.Class as X 8 | -------------------------------------------------------------------------------- /src/Reflex/DynamicWriter/Class.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines the 'DynamicWriter' class. 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | #ifdef USE_REFLEX_OPTIMIZER 8 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 9 | #endif 10 | module Reflex.DynamicWriter.Class 11 | ( MonadDynamicWriter 12 | , DynamicWriter(..) 13 | ) where 14 | 15 | import Control.Monad.Reader (ReaderT, lift) 16 | import Reflex.Class (Dynamic) 17 | 18 | {-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-} 19 | -- | Type synonym for 'DynamicWriter' 20 | type MonadDynamicWriter = DynamicWriter 21 | 22 | -- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn' 23 | -- and combines them monoidally to provide a 'Dynamic' result. 24 | class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where 25 | tellDyn :: Dynamic t w -> m () 26 | 27 | instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where 28 | tellDyn = lift . tellDyn 29 | -------------------------------------------------------------------------------- /src/Reflex/EventWriter.hs: -------------------------------------------------------------------------------- 1 | module Reflex.EventWriter 2 | {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-} 3 | ( module X 4 | ) where 5 | 6 | import Reflex.EventWriter.Base as X 7 | import Reflex.EventWriter.Class as X 8 | -------------------------------------------------------------------------------- /src/Reflex/EventWriter/Class.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines the 'EventWriter' class. 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | #ifdef USE_REFLEX_OPTIMIZER 7 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 8 | #endif 9 | module Reflex.EventWriter.Class 10 | ( EventWriter (..) 11 | ) where 12 | 13 | import Control.Monad.Reader (ReaderT, lift) 14 | 15 | import Reflex.Class (Event) 16 | 17 | 18 | -- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent' 19 | -- and combines them via 'Semigroup' to provide an 'Event' result. 20 | class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where 21 | tellEvent :: Event t w -> m () 22 | 23 | 24 | instance EventWriter t w m => EventWriter t w (ReaderT r m) where 25 | tellEvent = lift . tellEvent 26 | -------------------------------------------------------------------------------- /src/Reflex/FastWeak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | #if GHCJS_FAST_WEAK 5 | {-# LANGUAGE ForeignFunctionInterface #-} 6 | {-# LANGUAGE JavaScriptFFI #-} 7 | #endif 8 | 9 | -- | 10 | -- Module: 11 | -- Reflex.FastWeak 12 | -- Description: 13 | -- 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value 14 | -- referred to by a 'FastWeak' stays live while the ticket is held (live). 15 | -- 16 | -- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper 17 | -- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same. 18 | -- 19 | -- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly 20 | -- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS. 21 | module Reflex.FastWeak 22 | ( FastWeakTicket 23 | , FastWeak 24 | , mkFastWeakTicket 25 | , getFastWeakTicketValue 26 | , getFastWeakTicketWeak 27 | , getFastWeakValue 28 | , getFastWeakTicket 29 | , emptyFastWeak 30 | #ifdef GHCJS_FAST_WEAK 31 | --TODO: Move these elsewhere 32 | , unsafeFromRawJSVal 33 | , unsafeToRawJSVal 34 | , js_isNull 35 | #endif 36 | ) where 37 | 38 | import GHC.Exts (Any) 39 | import Unsafe.Coerce 40 | 41 | #ifdef GHCJS_FAST_WEAK 42 | import GHCJS.Types 43 | #else 44 | import Control.Exception (evaluate) 45 | import System.IO.Unsafe 46 | import System.Mem.Weak 47 | #endif 48 | 49 | 50 | #ifdef GHCJS_FAST_WEAK 51 | -- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' 52 | -- can be used to get the referred to value without fear of @Nothing, 53 | -- and 'getFastWeakTicketWeak' can be used to get the weak version. 54 | -- 55 | -- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@. 56 | newtype FastWeakTicket a = FastWeakTicket JSVal 57 | 58 | -- | A reference to some value which can be garbage collected if there are only 59 | -- weak references to the value left. 60 | -- 61 | -- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. 62 | -- 63 | -- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 64 | -- 'getFastWeakTicket' if the value hasn't been collected yet. 65 | -- 66 | -- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@. 67 | newtype FastWeak a = FastWeak JSVal 68 | 69 | -- Just designed to mirror JSVal, so that we can unsafeCoerce between the two 70 | data Val a = Val { unVal :: a } 71 | 72 | -- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@ 73 | unsafeFromRawJSVal :: JSVal -> a 74 | unsafeFromRawJSVal v = unVal (unsafeCoerce v) 75 | 76 | -- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object. 77 | unsafeToRawJSVal :: a -> JSVal 78 | unsafeToRawJSVal v = unsafeCoerce (Val v) 79 | #else 80 | -- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' 81 | -- can be used to get the referred to value without fear of @Nothing@, 82 | -- and 'getFastWeakTicketWeak' can be used to get the weak version. 83 | data FastWeakTicket a = FastWeakTicket 84 | { _fastWeakTicket_val :: !a 85 | , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a) 86 | } 87 | 88 | -- | A reference to some value which can be garbage collected if there are only weak references to the value left. 89 | -- 90 | -- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. 91 | -- 92 | -- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket' 93 | -- if the value hasn't been collected yet. 94 | -- 95 | -- Synonymous with 'Weak'. 96 | type FastWeak a = Weak a 97 | #endif 98 | 99 | -- | Return the @a@ kept alive by the given 'FastWeakTicket'. 100 | -- 101 | -- This needs to be in IO so we know that we've relinquished the ticket. 102 | getFastWeakTicketValue :: FastWeakTicket a -> IO a 103 | #ifdef GHCJS_FAST_WEAK 104 | getFastWeakTicketValue t = do 105 | v <- js_ticketVal t 106 | return $ unsafeFromRawJSVal v 107 | 108 | foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal 109 | #else 110 | getFastWeakTicketValue = return . _fastWeakTicket_val 111 | #endif 112 | 113 | -- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected, 114 | -- or @Nothing@ if it has been collected. 115 | getFastWeakValue :: FastWeak a -> IO (Maybe a) 116 | #ifdef GHCJS_FAST_WEAK 117 | getFastWeakValue w = do 118 | r <- js_weakVal w 119 | case js_isNull r of 120 | True -> return Nothing 121 | False -> return $ Just $ unsafeFromRawJSVal r 122 | 123 | foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool 124 | 125 | foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal 126 | #else 127 | getFastWeakValue = deRefWeak 128 | #endif 129 | 130 | -- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred 131 | -- remains alive. Returns @Just@ if the value hasn't been collected 132 | -- and a ticket can therefore be obtained, @Nothing@ if it's been collected. 133 | getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a)) 134 | #ifdef GHCJS_FAST_WEAK 135 | getFastWeakTicket w = do 136 | r <- js_weakTicket w 137 | case js_isNull r of 138 | True -> return Nothing 139 | False -> return $ Just $ FastWeakTicket r 140 | 141 | foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal 142 | #else 143 | getFastWeakTicket w = do 144 | deRefWeak w >>= \case 145 | Nothing -> return Nothing 146 | Just v -> return $ Just $ FastWeakTicket 147 | { _fastWeakTicket_val = v 148 | , _fastWeakTicket_weak = w 149 | } 150 | #endif 151 | 152 | -- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process 153 | -- which can be obtained with 'getFastWeakTicketValue'. 154 | -- 155 | -- This function is marked NOINLINE so it is opaque to GHC. 156 | -- If we do not do this, then GHC will sometimes fuse the constructor away 157 | -- so any weak references that are attached to the ticket will have their 158 | -- finalizer run. Using the opaque constructor, GHC does not see the 159 | -- constructor application, so it behaves like an IORef and cannot be fused away. 160 | -- 161 | -- The result is also evaluated to WHNF, since forcing a thunk invalidates 162 | -- the weak pointer to it in some cases. 163 | {-# NOINLINE mkFastWeakTicket #-} 164 | mkFastWeakTicket :: a -> IO (FastWeakTicket a) 165 | -- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the 166 | -- associated FastWeak to actually be weak 167 | #ifdef GHCJS_FAST_WEAK 168 | mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v) 169 | 170 | foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a) 171 | #else 172 | mkFastWeakTicket v = do 173 | v' <- evaluate v 174 | w <- mkWeakPtr v' Nothing 175 | return $ FastWeakTicket 176 | { _fastWeakTicket_val = v' 177 | , _fastWeakTicket_weak = w 178 | } 179 | #endif 180 | 181 | -- | Demote a 'FastWeakTicket'; which ensures the value is alive, to a 'FastWeak' which doesn't. 182 | -- Note that unless the ticket for the same 'FastWeak' is held in some other way 183 | -- the value might be collected immediately. 184 | getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a) 185 | -- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value 186 | #ifdef GHCJS_FAST_WEAK 187 | foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a) 188 | {-# INLINE getFastWeakTicketWeak #-} 189 | getFastWeakTicketWeak = getFastWeakTicketWeak' 190 | #else 191 | getFastWeakTicketWeak = return . _fastWeakTicket_weak 192 | #endif 193 | 194 | -- | A weak reference that is always empty 195 | emptyFastWeak :: FastWeak a 196 | emptyFastWeak = unsafeCoerce w 197 | where w :: FastWeak Any 198 | #ifdef GHCJS_FAST_WEAK 199 | w = js_emptyWeak 200 | #else 201 | w = unsafePerformIO $ do 202 | w' <- mkWeakPtr undefined Nothing 203 | finalize w' 204 | return w' 205 | #endif 206 | {-# NOINLINE emptyFastWeak #-} 207 | 208 | #ifdef GHCJS_FAST_WEAK 209 | foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any 210 | #endif 211 | -------------------------------------------------------------------------------- /src/Reflex/FunctorMaybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | 5 | -- | 6 | -- Module: 7 | -- Reflex.FunctorMaybe 8 | -- Description: 9 | -- This module defines the FunctorMaybe class, which extends Functors with the 10 | -- ability to delete values. 11 | module Reflex.FunctorMaybe 12 | ( FunctorMaybe (..) 13 | ) where 14 | 15 | import Data.IntMap (IntMap) 16 | import Data.Map (Map) 17 | #if !MIN_VERSION_base(4,16,0) 18 | import Data.Semigroup (Option(..)) 19 | #endif 20 | import Witherable 21 | 22 | --TODO: See if there's a better class in the standard libraries already 23 | 24 | -- | A class for values that combines filtering and mapping using 'Maybe'. 25 | -- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. 26 | {-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-} 27 | class FunctorMaybe f where 28 | -- | Combined mapping and filtering function. 29 | fmapMaybe :: (a -> Maybe b) -> f a -> f b 30 | 31 | instance FunctorMaybe Maybe where 32 | fmapMaybe = mapMaybe 33 | 34 | #if !MIN_VERSION_base(4,16,0) 35 | deriving instance FunctorMaybe Option 36 | #endif 37 | 38 | instance FunctorMaybe [] where 39 | fmapMaybe = mapMaybe 40 | 41 | instance FunctorMaybe (Map k) where 42 | fmapMaybe = mapMaybe 43 | 44 | instance FunctorMaybe IntMap where 45 | fmapMaybe = mapMaybe 46 | -------------------------------------------------------------------------------- /src/Reflex/Host/Headless.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Reflex.Host.Headless where 9 | 10 | import Control.Concurrent.Chan (newChan, readChan) 11 | import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) 12 | import Control.Monad.Fix (MonadFix, fix) 13 | import Control.Monad.IO.Class (MonadIO, liftIO) 14 | import Control.Monad.Primitive (PrimMonad) 15 | import Control.Monad.Ref (MonadRef, Ref, readRef) 16 | import Data.Dependent.Sum (DSum (..), (==>)) 17 | import Data.Foldable (for_, asum) 18 | import Data.Functor.Identity (Identity(..)) 19 | import Data.IORef (IORef, readIORef) 20 | import Data.Maybe (catMaybes) 21 | import Data.Traversable (for) 22 | 23 | import Reflex 24 | import Reflex.Host.Class 25 | 26 | type MonadHeadlessApp t m = 27 | ( Reflex t 28 | , Adjustable t m 29 | , MonadCatch m 30 | , MonadFix (Performable m) 31 | , MonadFix m 32 | , MonadHold t (Performable m) 33 | , MonadHold t m 34 | , MonadIO (HostFrame t) 35 | , MonadIO (Performable m) 36 | , MonadIO m 37 | , MonadMask m 38 | , MonadRef (HostFrame t) 39 | , MonadSample t (Performable m) 40 | , MonadSample t m 41 | , MonadThrow m 42 | , NotReady t m 43 | , PerformEvent t m 44 | , PostBuild t m 45 | , PrimMonad (HostFrame t) 46 | , Ref (HostFrame t) ~ IORef 47 | , Ref m ~ IORef 48 | , ReflexHost t 49 | , TriggerEvent t m 50 | ) 51 | 52 | -- | Run a headless FRP network. Inside the action, you will most probably use 53 | -- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type 54 | -- classes to interface the FRP network with the outside world. Useful for 55 | -- testing. Each headless network runs on its own spider timeline. 56 | runHeadlessApp 57 | :: forall a 58 | . (forall t m. MonadHeadlessApp t m => m (Event t a)) 59 | -- ^ The action to be run in the headless FRP network. The FRP network is 60 | -- closed at the first occurrence of the resulting 'Event'. 61 | -> IO a 62 | runHeadlessApp guest = 63 | -- We are using the 'Spider' implementation of reflex. Running the host 64 | -- allows us to take actions on the FRP timeline. 65 | withSpiderTimeline $ runSpiderHostForTimeline $ do 66 | -- Create the "post-build" event and associated trigger. This event fires 67 | -- once, when the application starts. 68 | (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef 69 | -- Create a queue to which we will write 'Event's that need to be 70 | -- processed. 71 | events <- liftIO newChan 72 | -- Run the "guest" application, providing the appropriate context. We'll 73 | -- pure the result of the action, and a 'FireCommand' that will be used to 74 | -- trigger events. 75 | (result, fc@(FireCommand fire)) <- do 76 | hostPerformEventT $ -- Allows the guest app to run 77 | -- 'performEvent', so that actions 78 | -- (e.g., IO actions) can be run when 79 | -- 'Event's fire. 80 | 81 | flip runPostBuildT postBuild $ -- Allows the guest app to access to 82 | -- a "post-build" 'Event' 83 | 84 | flip runTriggerEventT events $ -- Allows the guest app to create new 85 | -- events and triggers and write 86 | -- those triggers to a channel from 87 | -- which they will be read and 88 | -- processed. 89 | guest 90 | 91 | -- Read the trigger reference for the post-build event. This will be 92 | -- 'Nothing' if the guest application hasn't subscribed to this event. 93 | mPostBuildTrigger <- readRef postBuildTriggerRef 94 | 95 | -- Subscribe to an 'Event' of that the guest application can use to 96 | -- request application shutdown. We'll check whether this 'Event' is firing 97 | -- to determine whether to terminate. 98 | shutdown <- subscribeEvent result 99 | 100 | -- When there is a subscriber to the post-build event, fire the event. 101 | initialShutdownEventFirings :: Maybe [Maybe a] <- for mPostBuildTrigger $ \postBuildTrigger -> 102 | fire [postBuildTrigger :=> Identity ()] $ sequence =<< readEvent shutdown 103 | let shutdownImmediately = case initialShutdownEventFirings of 104 | -- We didn't even fire postBuild because it wasn't subscribed 105 | Nothing -> Nothing 106 | -- Take the first Just, if there is one. Ideally, we should cut off 107 | -- the event loop as soon as the firing happens, but Performable 108 | -- doesn't currently give us an easy way to do that 109 | Just firings -> asum firings 110 | 111 | case shutdownImmediately of 112 | Just exitResult -> pure exitResult 113 | -- The main application loop. We wait for new events and fire those that 114 | -- have subscribers. If we detect a shutdown request, the application 115 | -- terminates. 116 | Nothing -> fix $ \loop -> do 117 | -- Read the next event (blocking). 118 | ers <- liftIO $ readChan events 119 | shutdownEventFirings :: [Maybe a] <- do 120 | -- Fire events that have subscribers. 121 | fireEventTriggerRefs fc ers $ 122 | -- Check if the shutdown 'Event' is firing. 123 | sequence =<< readEvent shutdown 124 | let -- If the shutdown event fires multiple times, take the first one. 125 | -- Ideally, we should cut off the event loop as soon as this fires, 126 | -- but Performable doesn't currently give us an easy way to do that. 127 | shutdownNow = asum shutdownEventFirings 128 | case shutdownNow of 129 | Just exitResult -> pure exitResult 130 | Nothing -> loop 131 | where 132 | -- Use the given 'FireCommand' to fire events that have subscribers 133 | -- and call the callback for the 'TriggerInvocation' of each. 134 | fireEventTriggerRefs 135 | :: forall b m t 136 | . MonadIO m 137 | => FireCommand t m 138 | -> [DSum (EventTriggerRef t) TriggerInvocation] 139 | -> ReadPhase m b 140 | -> m [b] 141 | fireEventTriggerRefs (FireCommand fire) ers rcb = do 142 | mes <- liftIO $ 143 | for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do 144 | me <- readIORef er 145 | pure $ fmap (==> a) me 146 | a <- fire (catMaybes mes) rcb 147 | liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb 148 | pure a 149 | -------------------------------------------------------------------------------- /src/Reflex/Network.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | #ifdef USE_REFLEX_OPTIMIZER 4 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 5 | #endif 6 | -- | 7 | -- Module: 8 | -- Reflex.Network 9 | -- Description: 10 | -- This module provides combinators for building FRP graphs/networks and modifying them dynamically. 11 | module Reflex.Network 12 | ( networkView 13 | , networkHold 14 | , untilReady 15 | ) where 16 | 17 | import Reflex.Class 18 | import Reflex.Adjustable.Class 19 | import Reflex.NotReady.Class 20 | import Reflex.PostBuild.Class 21 | 22 | -- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates. 23 | -- The returned Event of network results fires at post-build time and when the 'Dynamic' updates. 24 | -- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires 25 | -- when switching networks. Such an 'Event' would typically be flattened (via 'switchHoldPromptly'). 26 | networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a) 27 | networkView child = do 28 | postBuild <- getPostBuild 29 | let newChild = leftmost [updated child, tagCheap (current child) postBuild] 30 | snd <$> runWithReplace notReady newChild 31 | 32 | -- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires. 33 | -- The returned Dynamic of network results occurs when the Event does. 34 | -- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened (via 'switchPromptlyDyn'). 35 | networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a) 36 | networkHold child0 newChild = do 37 | (result0, newResult) <- runWithReplace child0 newChild 38 | holdDyn result0 newResult 39 | 40 | -- | Render a placeholder network to be shown while another network is not yet 41 | -- done building 42 | untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b) 43 | untilReady a b = do 44 | postBuild <- getPostBuild 45 | runWithReplace a $ b <$ postBuild 46 | -------------------------------------------------------------------------------- /src/Reflex/NotReady/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | #ifdef USE_REFLEX_OPTIMIZER 10 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 11 | #endif 12 | module Reflex.NotReady.Class 13 | ( NotReady(..) 14 | ) where 15 | 16 | import Control.Monad.Reader (ReaderT) 17 | import Control.Monad.Trans 18 | import Control.Monad.Trans.Writer (WriterT) 19 | 20 | import Reflex.BehaviorWriter.Base (BehaviorWriterT) 21 | import Reflex.Class 22 | import Reflex.DynamicWriter.Base (DynamicWriterT) 23 | import Reflex.EventWriter.Base (EventWriterT) 24 | import Reflex.Host.Class 25 | import Reflex.PerformEvent.Base (PerformEventT (..)) 26 | import Reflex.PostBuild.Base (PostBuildT) 27 | import Reflex.Query.Base (QueryT) 28 | import Reflex.Requester.Base (RequesterT) 29 | import Reflex.TriggerEvent.Base (TriggerEventT) 30 | 31 | class Monad m => NotReady t m | m -> t where 32 | notReadyUntil :: Event t a -> m () 33 | default notReadyUntil :: (MonadTrans f, m ~ f m', NotReady t m') => Event t a -> m () 34 | notReadyUntil = lift . notReadyUntil 35 | 36 | notReady :: m () 37 | default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m () 38 | notReady = lift notReady 39 | 40 | instance NotReady t m => NotReady t (ReaderT r m) where 41 | notReadyUntil = lift . notReadyUntil 42 | notReady = lift notReady 43 | 44 | instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where 45 | notReadyUntil = lift . notReadyUntil 46 | notReady = lift notReady 47 | 48 | instance NotReady t m => NotReady t (PostBuildT t m) where 49 | notReadyUntil = lift . notReadyUntil 50 | notReady = lift notReady 51 | 52 | instance NotReady t m => NotReady t (EventWriterT t w m) where 53 | notReadyUntil = lift . notReadyUntil 54 | notReady = lift notReady 55 | 56 | instance NotReady t m => NotReady t (DynamicWriterT t w m) where 57 | notReadyUntil = lift . notReadyUntil 58 | notReady = lift notReady 59 | 60 | instance NotReady t m => NotReady t (BehaviorWriterT t w m) where 61 | notReadyUntil = lift . notReadyUntil 62 | notReady = lift notReady 63 | 64 | instance NotReady t m => NotReady t (QueryT t q m) where 65 | notReadyUntil = lift . notReadyUntil 66 | notReady = lift notReady 67 | 68 | instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where 69 | notReadyUntil = PerformEventT . notReadyUntil 70 | notReady = PerformEventT notReady 71 | 72 | instance NotReady t m => NotReady t (RequesterT t request response m) where 73 | notReadyUntil = lift . notReadyUntil 74 | notReady = lift notReady 75 | 76 | instance NotReady t m => NotReady t (TriggerEventT t m) where 77 | notReadyUntil = lift . notReadyUntil 78 | notReady = lift notReady 79 | -------------------------------------------------------------------------------- /src/Reflex/Optimizer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | -- | 5 | -- Module: 6 | -- Reflex.Optimizer 7 | -- Description: 8 | -- This module provides a GHC plugin designed to improve code that uses 9 | -- Reflex. Currently, it just adds an INLINABLE pragma to any top-level 10 | -- definition that doesn't have an explicit inlining pragma. In the future, 11 | -- additional optimizations are likely to be added. 12 | module Reflex.Optimizer 13 | ( plugin 14 | ) where 15 | 16 | #ifdef ghcjs_HOST_OS 17 | import Plugins 18 | #else 19 | import Control.Arrow 20 | import CoreMonad 21 | import Data.String 22 | import GhcPlugins 23 | 24 | import Prelude hiding ((<>)) 25 | 26 | #endif 27 | 28 | #ifdef ghcjs_HOST_OS 29 | 30 | -- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used. 31 | plugin :: Plugin 32 | plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS." 33 | 34 | #else 35 | 36 | -- | The GHC plugin itself. See "GhcPlugins" for more details. 37 | plugin :: Plugin 38 | plugin = defaultPlugin { installCoreToDos = install } 39 | 40 | install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] 41 | install [] p = do 42 | liftIO $ putStrLn $ showSDocUnsafe $ ppr p 43 | let f = \case 44 | simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl] 45 | x -> [x] 46 | return $ makeInlinable : concatMap f p 47 | install options@(_:_) p = do 48 | warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options" 49 | install [] p 50 | 51 | makeInlinable :: CoreToDo 52 | makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do 53 | let f v = setIdInfo v $ let i = idInfo v in 54 | setInlinePragInfo i $ let p = inlinePragInfo i in 55 | if isDefaultInlinePragma p 56 | then defaultInlinePragma { inl_inline = Inlinable } 57 | else p 58 | newBinds = flip map (mg_binds modGuts) $ \case 59 | NonRec b e -> NonRec (f b) e 60 | Rec bes -> Rec $ map (first f) bes 61 | return $ modGuts { mg_binds = newBinds } 62 | 63 | #endif 64 | -------------------------------------------------------------------------------- /src/Reflex/PerformEvent/Class.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'PerformEvent', which mediates the 2 | -- interaction between a "Reflex"-based program and the external side-effecting 3 | -- actions such as 'IO'. 4 | {-# LANGUAGE CPP #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | #ifdef USE_REFLEX_OPTIMIZER 13 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 14 | #endif 15 | module Reflex.PerformEvent.Class 16 | ( PerformEvent (..) 17 | , performEventAsync 18 | ) where 19 | 20 | import Control.Monad 21 | import Control.Monad.Reader 22 | import Control.Monad.Trans.Maybe (MaybeT (..)) 23 | 24 | import Data.Kind (Type) 25 | 26 | import Reflex.Class 27 | import Reflex.TriggerEvent.Class 28 | 29 | -- | 'PerformEvent' represents actions that can trigger other actions based on 30 | -- 'Event's. 31 | class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where 32 | -- | The type of action to be triggered; this is often not the same type as 33 | -- the triggering action. 34 | type Performable m :: Type -> Type 35 | -- | Perform the action contained in the given 'Event' whenever the 'Event' 36 | -- fires. Return the result in another 'Event'. Note that the output 'Event' 37 | -- will generally occur later than the input 'Event', since most 'Performable' 38 | -- actions cannot be performed during 'Event' propagation. 39 | performEvent :: Event t (Performable m a) -> m (Event t a) 40 | -- | Like 'performEvent', but do not return the result. May have slightly 41 | -- better performance. 42 | performEvent_ :: Event t (Performable m ()) -> m () 43 | 44 | -- | Like 'performEvent', but the resulting 'Event' occurs only when the 45 | -- callback (@a -> IO ()@) is called, not when the included action finishes. 46 | -- 47 | -- NOTE: Despite the name, 'performEventAsync' does not run its action in a 48 | -- separate thread - although the action is free to invoke forkIO and then call 49 | -- the callback whenever it is ready. This will work properly, even in GHCJS 50 | -- (which fully implements concurrency even though JavaScript does not have 51 | -- built in concurrency). 52 | {-# INLINABLE performEventAsync #-} 53 | performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a) 54 | performEventAsync e = do 55 | (eOut, triggerEOut) <- newTriggerEvent 56 | performEvent_ $ fmap ($ triggerEOut) e 57 | return eOut 58 | 59 | instance PerformEvent t m => PerformEvent t (ReaderT r m) where 60 | type Performable (ReaderT r m) = ReaderT r (Performable m) 61 | performEvent_ e = do 62 | r <- ask 63 | lift $ performEvent_ $ flip runReaderT r <$> e 64 | performEvent e = do 65 | r <- ask 66 | lift $ performEvent $ flip runReaderT r <$> e 67 | 68 | instance PerformEvent t m => PerformEvent t (MaybeT m) where 69 | type Performable (MaybeT m) = MaybeT (Performable m) 70 | performEvent_ = lift . performEvent_ . fmapCheap (void . runMaybeT) 71 | performEvent = lift . fmap (fmapMaybe id) . performEvent . fmapCheap runMaybeT 72 | -------------------------------------------------------------------------------- /src/Reflex/PostBuild/Base.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'PostBuildT', the standard implementation of 2 | -- 'PostBuild'. 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE RecursiveDo #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | #ifdef USE_REFLEX_OPTIMIZER 14 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 15 | #endif 16 | module Reflex.PostBuild.Base 17 | ( PostBuildT (..) 18 | , runPostBuildT 19 | -- * Internal 20 | , mapIntMapWithAdjustImpl 21 | , mapDMapWithAdjustImpl 22 | ) where 23 | 24 | import Reflex.Class 25 | import Reflex.Adjustable.Class 26 | import Reflex.Host.Class 27 | import Reflex.PerformEvent.Class 28 | import Reflex.PostBuild.Class 29 | import Reflex.TriggerEvent.Class 30 | 31 | import Control.Applicative (liftA2) 32 | import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) 33 | import Control.Monad.Exception 34 | import Control.Monad.Fix 35 | import Control.Monad.Primitive 36 | import Control.Monad.Reader 37 | import Control.Monad.Ref 38 | import qualified Control.Monad.Trans.Control as TransControl 39 | import Data.Dependent.Map (DMap) 40 | import qualified Data.Dependent.Map as DMap 41 | import Data.Functor.Compose 42 | import Data.IntMap.Strict (IntMap) 43 | import qualified Data.IntMap.Strict as IntMap 44 | import qualified Data.Semigroup as S 45 | 46 | -- | Provides a basic implementation of 'PostBuild'. 47 | newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } 48 | deriving 49 | ( Functor 50 | , Applicative 51 | , Monad 52 | , MonadFix 53 | , MonadIO 54 | , MonadTrans 55 | , MonadException 56 | , MonadAsyncException 57 | , MonadMask 58 | , MonadThrow 59 | , MonadCatch 60 | ) 61 | 62 | -- | Run a 'PostBuildT' action. An 'Event' should be provided that fires 63 | -- immediately after the action is finished running; no other 'Event's should 64 | -- fire first. 65 | {-# INLINABLE runPostBuildT #-} 66 | runPostBuildT :: PostBuildT t m a -> Event t () -> m a 67 | runPostBuildT (PostBuildT a) = runReaderT a 68 | 69 | -- TODO: Monoid and Semigroup can likely be derived once ReaderT has them. 70 | instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where 71 | mempty = pure mempty 72 | 73 | instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where 74 | (<>) = liftA2 (S.<>) 75 | 76 | instance PrimMonad m => PrimMonad (PostBuildT x m) where 77 | type PrimState (PostBuildT x m) = PrimState m 78 | primitive = lift . primitive 79 | 80 | instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where 81 | {-# INLINABLE getPostBuild #-} 82 | getPostBuild = PostBuildT ask 83 | 84 | instance MonadSample t m => MonadSample t (PostBuildT t m) where 85 | {-# INLINABLE sample #-} 86 | sample = lift . sample 87 | 88 | instance MonadHold t m => MonadHold t (PostBuildT t m) where 89 | {-# INLINABLE hold #-} 90 | hold v0 = lift . hold v0 91 | {-# INLINABLE holdDyn #-} 92 | holdDyn v0 = lift . holdDyn v0 93 | {-# INLINABLE holdIncremental #-} 94 | holdIncremental v0 = lift . holdIncremental v0 95 | {-# INLINABLE buildDynamic #-} 96 | buildDynamic a0 = lift . buildDynamic a0 97 | {-# INLINABLE headE #-} 98 | headE = lift . headE 99 | {-# INLINABLE now #-} 100 | now = lift now 101 | 102 | instance PerformEvent t m => PerformEvent t (PostBuildT t m) where 103 | type Performable (PostBuildT t m) = Performable m 104 | {-# INLINABLE performEvent_ #-} 105 | performEvent_ = lift . performEvent_ 106 | {-# INLINABLE performEvent #-} 107 | performEvent = lift . performEvent 108 | 109 | instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where 110 | {-# INLINABLE newEventWithTrigger #-} 111 | newEventWithTrigger = PostBuildT . lift . newEventWithTrigger 112 | {-# INLINABLE newFanEventWithTrigger #-} 113 | newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f 114 | 115 | instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where 116 | {-# INLINABLE newTriggerEvent #-} 117 | newTriggerEvent = lift newTriggerEvent 118 | {-# INLINABLE newTriggerEventWithOnComplete #-} 119 | newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete 120 | newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete 121 | 122 | instance MonadRef m => MonadRef (PostBuildT t m) where 123 | type Ref (PostBuildT t m) = Ref m 124 | {-# INLINABLE newRef #-} 125 | newRef = lift . newRef 126 | {-# INLINABLE readRef #-} 127 | readRef = lift . readRef 128 | {-# INLINABLE writeRef #-} 129 | writeRef r = lift . writeRef r 130 | 131 | instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where 132 | {-# INLINABLE atomicModifyRef #-} 133 | atomicModifyRef r = lift . atomicModifyRef r 134 | 135 | instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where 136 | runWithReplace a0 a' = do 137 | postBuild <- getPostBuild 138 | lift $ do 139 | rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a' 140 | let voidResult' = fmapCheap (\_ -> ()) result' 141 | return result 142 | {-# INLINABLE traverseIntMapWithKeyWithAdjust #-} 143 | traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust 144 | {-# INLINABLE traverseDMapWithKeyWithAdjust #-} 145 | traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap 146 | traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove 147 | 148 | {-# INLINABLE mapIntMapWithAdjustImpl #-} 149 | mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p) 150 | => ( (IntMap.Key -> (Event t (), v) -> m v') 151 | -> IntMap (Event t (), v) 152 | -> Event t (p (Event t (), v)) 153 | -> m (IntMap v', Event t (p v')) 154 | ) 155 | -> (IntMap.Key -> v -> PostBuildT t m v') 156 | -> IntMap v 157 | -> Event t (p v) 158 | -> PostBuildT t m (IntMap v', Event t (p v')) 159 | mapIntMapWithAdjustImpl base f dm0 dm' = do 160 | postBuild <- getPostBuild 161 | let loweredDm0 = fmap ((,) postBuild) dm0 162 | f' :: IntMap.Key -> (Event t (), v) -> m v' 163 | f' k (e, v) = do 164 | runPostBuildT (f k v) e 165 | lift $ do 166 | rec (result0, result') <- base f' loweredDm0 loweredDm' 167 | cohortDone <- numberOccurrencesFrom_ 1 result' 168 | numberedDm' <- numberOccurrencesFrom 1 dm' 169 | let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone 170 | loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do 171 | return $ fmap ((,) (selectInt postBuild' n)) p 172 | return (result0, result') 173 | 174 | {-# INLINABLE mapDMapWithAdjustImpl #-} 175 | mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m) 176 | => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)) 177 | -> DMap k (Compose ((,) (Bool, Event t ())) v) 178 | -> Event t (p k (Compose ((,) (Bool, Event t ())) v)) 179 | -> m (DMap k v', Event t (p k v')) 180 | ) 181 | -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v)) 182 | -> (forall a. k a -> v a -> PostBuildT t m (v' a)) 183 | -> DMap k v 184 | -> Event t (p k v) 185 | -> PostBuildT t m (DMap k v', Event t (p k v')) 186 | mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do 187 | postBuild <- getPostBuild 188 | let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0 189 | f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a) 190 | f' k (Compose ((shouldHeadE, e), v)) = do 191 | eOnce <- if shouldHeadE 192 | then headE e --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence 193 | else return e 194 | runPostBuildT (f k v) eOnce 195 | lift $ do 196 | rec (result0, result') <- base f' loweredDm0 loweredDm' 197 | let voidResult' = fmapCheap (\_ -> ()) result' 198 | let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult')) 199 | return (result0, result') 200 | 201 | -------------------------------------------------------------------------------- 202 | -- Deprecated functionality 203 | -------------------------------------------------------------------------------- 204 | 205 | -- | Deprecated 206 | instance TransControl.MonadTransControl (PostBuildT t) where 207 | type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a 208 | {-# INLINABLE liftWith #-} 209 | liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT 210 | {-# INLINABLE restoreT #-} 211 | restoreT = TransControl.defaultRestoreT PostBuildT 212 | -------------------------------------------------------------------------------- /src/Reflex/PostBuild/Class.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'PostBuild', which indicates that an action will be 2 | -- notified when it, and any action it's a part of, has finished executing. 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | #ifdef USE_REFLEX_OPTIMIZER 11 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 12 | #endif 13 | module Reflex.PostBuild.Class 14 | ( PostBuild (..) 15 | ) where 16 | 17 | import Reflex.Class 18 | 19 | import Control.Monad.Reader 20 | import Control.Monad.State 21 | import qualified Control.Monad.State.Strict as Strict 22 | 23 | -- | 'PostBuild' represents an action that is notified via an 'Event' when it 24 | -- has finished executing. Note that the specific definition of "finished" is 25 | -- determined by the instance of 'PostBuild', but the intent is to allow 26 | -- 'Behavior's and 'Dynamic's to be safely sampled, regardless of where they 27 | -- were created, when the post-build 'Event' fires. The post-build 'Event' will 28 | -- fire exactly once for an given action. 29 | class (Reflex t, Monad m) => PostBuild t m | m -> t where 30 | -- | Retrieve the post-build 'Event' for this action. 31 | getPostBuild :: m (Event t ()) 32 | 33 | instance PostBuild t m => PostBuild t (ReaderT r m) where 34 | getPostBuild = lift getPostBuild 35 | 36 | instance PostBuild t m => PostBuild t (StateT s m) where 37 | getPostBuild = lift getPostBuild 38 | 39 | instance PostBuild t m => PostBuild t (Strict.StateT s m) where 40 | getPostBuild = lift getPostBuild 41 | -------------------------------------------------------------------------------- /src/Reflex/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | 12 | #ifdef USE_REFLEX_OPTIMIZER 13 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 14 | #endif 15 | 16 | -- There are two expected orphan instances in this module: 17 | -- * MonadSample (Pure t) ((->) t) 18 | -- * MonadHold (Pure t) ((->) t) 19 | {-# OPTIONS_GHC -fno-warn-orphans #-} 20 | -- | 21 | -- Module: Reflex.Pure 22 | -- Description: 23 | -- This module provides a pure implementation of Reflex, which is intended to 24 | -- serve as a reference for the semantics of the Reflex class. All 25 | -- implementations of Reflex should produce the same results as this 26 | -- implementation, although performance and laziness/strictness may differ. 27 | module Reflex.Pure 28 | ( Pure 29 | , Behavior (..) 30 | , Event (..) 31 | , Dynamic (..) 32 | , Incremental (..) 33 | ) where 34 | 35 | import Control.Monad 36 | import Data.Dependent.Map (DMap) 37 | import Data.GADT.Compare (GCompare) 38 | import qualified Data.Dependent.Map as DMap 39 | import Data.IntMap (IntMap) 40 | import qualified Data.IntMap as IntMap 41 | import Data.Maybe 42 | import Data.MemoTrie 43 | import Data.Monoid 44 | import Data.Type.Coercion 45 | import Reflex.Class 46 | import Data.Kind (Type) 47 | 48 | -- | A completely pure-functional 'Reflex' timeline, identifying moments in time 49 | -- with the type @/t/@. 50 | data Pure (t :: Type) 51 | 52 | -- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist 53 | -- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used 54 | -- exclusively to memoize functions of @/t/@, not for any of its other capabilities. 55 | instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where 56 | 57 | newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a } 58 | newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a } 59 | newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) } 60 | newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) } 61 | 62 | type PushM (Pure t) = (->) t 63 | type PullM (Pure t) = (->) t 64 | 65 | never :: Event (Pure t) a 66 | never = Event $ \_ -> Nothing 67 | 68 | constant :: a -> Behavior (Pure t) a 69 | constant x = Behavior $ \_ -> x 70 | 71 | push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b 72 | push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t 73 | 74 | pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b 75 | pushCheap = push 76 | 77 | pull :: PullM (Pure t) a -> Behavior (Pure t) a 78 | pull = Behavior . memo 79 | 80 | -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a 81 | -- warning because the GCompare instance is not used; however, removing the 82 | -- GCompare instance produces a different warning, due to that constraint 83 | -- being present in the original class definition. 84 | 85 | --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a)) 86 | -- -> DMap k q -> Event (Pure t) (DMap k v) 87 | mergeG nt events = Event $ memo $ \t -> 88 | let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events 89 | in if DMap.null currentOccurrences 90 | then Nothing 91 | else Just currentOccurrences 92 | 93 | -- The instance signature doeesn't compile, leave commented for documentation 94 | -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v 95 | fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k 96 | 97 | switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a 98 | switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t 99 | 100 | coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a 101 | coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t 102 | 103 | current :: Dynamic (Pure t) a -> Behavior (Pure t) a 104 | current d = Behavior $ \t -> fst $ unDynamic d t 105 | 106 | updated :: Dynamic (Pure t) a -> Event (Pure t) a 107 | updated d = Event $ \t -> snd $ unDynamic d t 108 | 109 | unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a 110 | unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t) 111 | 112 | -- See UNUSED_CONSTRAINT, above. 113 | 114 | --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p 115 | --a) -> Incremental (Pure t) p a 116 | unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t) 117 | 118 | mergeIncrementalG = mergeIncrementalImpl 119 | mergeIncrementalWithMoveG = mergeIncrementalImpl 120 | 121 | currentIncremental i = Behavior $ \t -> fst $ unIncremental i t 122 | 123 | updatedIncremental i = Event $ \t -> snd $ unIncremental i t 124 | 125 | incrementalToDynamic i = Dynamic $ \t -> 126 | let (old, mPatch) = unIncremental i t 127 | e = case mPatch of 128 | Nothing -> Nothing 129 | Just patch -> apply patch old 130 | in (old, e) 131 | behaviorCoercion Coercion = Coercion 132 | eventCoercion Coercion = Coercion 133 | dynamicCoercion Coercion = Coercion 134 | incrementalCoercion Coercion Coercion = Coercion 135 | 136 | fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k 137 | 138 | mergeIntIncremental = mergeIntIncrementalImpl 139 | 140 | mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k) 141 | => (forall a. q a -> Event (Pure t) (v a)) 142 | -> Incremental (Pure t) p -> Event (Pure t) (DMap k v) 143 | mergeIncrementalImpl nt i = Event $ \t -> 144 | let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t 145 | in if DMap.null results 146 | then Nothing 147 | else Just results 148 | 149 | mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a) 150 | mergeIntIncrementalImpl i = Event $ \t -> 151 | let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t 152 | in if IntMap.null results 153 | then Nothing 154 | else Just results 155 | 156 | instance Functor (Dynamic (Pure t)) where 157 | fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t 158 | in (f cur, fmap f upd) 159 | 160 | instance Applicative (Dynamic (Pure t)) where 161 | pure a = Dynamic $ \_ -> (a, Nothing) 162 | (<*>) = ap 163 | 164 | instance Monad (Dynamic (Pure t)) where 165 | return = pure 166 | (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t -> 167 | let (curX :: a, updX :: Maybe a) = unDynamic x t 168 | (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t 169 | (updInner :: Maybe b, updBoth :: Maybe b) = case updX of 170 | Nothing -> (Nothing, Nothing) 171 | Just nextX -> let (c, u) = unDynamic (f nextX) t 172 | in (Just c, u) 173 | in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner]) 174 | 175 | instance MonadSample (Pure t) ((->) t) where 176 | 177 | sample :: Behavior (Pure t) a -> (t -> a) 178 | sample = unBehavior 179 | 180 | instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where 181 | 182 | hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a 183 | hold initialValue e initialTime = Behavior f 184 | where f = memo $ \sampleTime -> 185 | -- Really, the sampleTime should never be prior to the initialTime, 186 | -- because that would mean the Behavior is being sampled before 187 | -- being created. 188 | if sampleTime <= initialTime 189 | then initialValue 190 | else let lastTime = pred sampleTime 191 | in fromMaybe (f lastTime) $ unEvent e lastTime 192 | 193 | holdDyn v0 = buildDynamic (return v0) 194 | 195 | buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a 196 | buildDynamic initialValue e initialTime = 197 | let Behavior f = hold (initialValue initialTime) e initialTime 198 | in Dynamic $ \t -> (f t, unEvent e t) 199 | 200 | holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p 201 | holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t) 202 | where f = memo $ \sampleTime -> 203 | -- Really, the sampleTime should never be prior to the initialTime, 204 | -- because that would mean the Behavior is being sampled before 205 | -- being created. 206 | if sampleTime <= initialTime 207 | then initialValue 208 | else let lastTime = pred sampleTime 209 | lastValue = f lastTime 210 | in case unEvent e lastTime of 211 | Nothing -> lastValue 212 | Just x -> fromMaybe lastValue $ apply x lastValue 213 | 214 | headE = slowHeadE 215 | now t = Event $ guard . (t ==) 216 | -------------------------------------------------------------------------------- /src/Reflex/Query/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | -- | 10 | -- Module: 11 | -- Reflex.Query.Class 12 | -- Description: 13 | -- A class that ties together queries to some data source and their results, 14 | -- providing methods for requesting data from the source and accumulating 15 | -- streamed results. 16 | module Reflex.Query.Class 17 | ( Query (..) 18 | , QueryMorphism (..) 19 | , SelectedCount (..) 20 | , combineSelectedCounts 21 | 22 | , MonadQuery (..) 23 | , tellQueryDyn 24 | , queryDyn 25 | , subQuery 26 | , mapQuery 27 | , mapQueryResult 28 | ) where 29 | 30 | import Control.Applicative 31 | import Control.Category (Category) 32 | import qualified Control.Category as Cat 33 | import Control.Monad.Reader 34 | import Data.Bits 35 | import Data.Data 36 | import Data.Ix 37 | import Data.Kind (Type) 38 | import Data.Map.Monoidal (MonoidalMap) 39 | import qualified Data.Map.Monoidal as MonoidalMap 40 | import Data.Semigroup.Commutative 41 | import Data.Void 42 | import Data.Monoid hiding ((<>)) 43 | import Foreign.Storable 44 | 45 | import Reflex.Class 46 | 47 | -- | A 'Query' can be thought of as a declaration of interest in some set of data. 48 | -- A 'QueryResult' is the set of data associated with that interest set. 49 | -- The @crop@ function provides a way to determine what part of a given 'QueryResult' 50 | -- is relevant to a given 'Query'. 51 | class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where 52 | type QueryResult a :: Type 53 | crop :: a -> QueryResult a -> QueryResult a 54 | 55 | instance (Ord k, Query v) => Query (MonoidalMap k v) where 56 | type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v) 57 | crop q r = MonoidalMap.intersectionWith (flip crop) r q 58 | 59 | -- | the result of two queries is both results. 60 | instance (Query a, Query b) => Query (a, b) where 61 | type QueryResult (a, b) = (QueryResult a, QueryResult b) 62 | crop (x, x') (y, y') = (crop x y, crop x' y') 63 | 64 | -- | Trivial queries have trivial results. 65 | instance Query () where 66 | type QueryResult () = () 67 | crop _ _ = () 68 | 69 | -- | The result of an absurd query is trivial; If you can ask the question, the 70 | -- answer cannot tell you anything you didn't already know. 71 | -- 72 | -- 'QueryResult Void = @Void@' seems like it would also work, but that has 73 | -- problems of robustness. In some applications, an unasked question can still 74 | -- be answered, so it is important that the result is inhabited even when the 75 | -- question isn't. Applications that wish to prevent this can mandate that the 76 | -- query result be paired with the query: then the whole response will be 77 | -- uninhabited as desired. 78 | instance Query Void where 79 | type QueryResult Void = () 80 | crop = absurd 81 | 82 | #if MIN_VERSION_base(4,12,0) 83 | -- | We can lift queries into monoidal containers. 84 | -- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend) 85 | instance (Query q, Applicative f) => Query (Ap f q) where 86 | type QueryResult (Ap f q) = Ap f (QueryResult q) 87 | crop = liftA2 crop 88 | #endif 89 | 90 | -- | QueryMorphism's must be group homomorphisms when acting on the query type 91 | -- and compatible with the query relationship when acting on the query result. 92 | data QueryMorphism q q' = QueryMorphism 93 | { _queryMorphism_mapQuery :: q -> q' 94 | , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q 95 | } 96 | 97 | instance Category QueryMorphism where 98 | id = QueryMorphism id id 99 | qm . qm' = QueryMorphism 100 | { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm' 101 | , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm 102 | } 103 | 104 | -- | Apply a 'QueryMorphism' to a 'Query' 105 | mapQuery :: QueryMorphism q q' -> q -> q' 106 | mapQuery = _queryMorphism_mapQuery 107 | 108 | -- | Map a 'QueryMorphism' to a 'QueryResult' 109 | mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q 110 | mapQueryResult = _queryMorphism_mapQueryResult 111 | 112 | -- | This type can be used to track of the frequency of interest in a given 'Query'. See note on 113 | -- 'combineSelectedCounts' 114 | newtype SelectedCount = SelectedCount { unSelectedCount :: Int } 115 | deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data) 116 | 117 | instance Semigroup SelectedCount where 118 | SelectedCount a <> SelectedCount b = SelectedCount (a + b) 119 | 120 | instance Monoid SelectedCount where 121 | mempty = SelectedCount 0 122 | mappend = (<>) 123 | 124 | instance Group SelectedCount where 125 | negateG (SelectedCount a) = SelectedCount (negate a) 126 | 127 | instance Commutative SelectedCount 128 | 129 | -- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use 130 | -- this function which returns Nothing if the result is 0. This allows the pruning of leaves 131 | -- of the 'Query' that are no longer wanted. 132 | combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount 133 | combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j) 134 | 135 | -- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly 136 | -- used interface. 137 | class (Group q, Commutative q, Query q, Monad m) => MonadQuery t q m | m -> q t where 138 | tellQueryIncremental :: Incremental t (AdditivePatch q) -> m () 139 | askQueryResult :: m (Dynamic t (QueryResult q)) 140 | queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q)) 141 | 142 | instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where 143 | tellQueryIncremental = lift . tellQueryIncremental 144 | askQueryResult = lift askQueryResult 145 | queryIncremental = lift . queryIncremental 146 | 147 | -- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'. 148 | tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m () 149 | tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d) 150 | 151 | -- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'. 152 | queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q)) 153 | queryDyn q = do 154 | tellQueryDyn q 155 | zipDynWith crop q <$> askQueryResult 156 | 157 | -- | Use a query morphism to operate on a smaller version of a query. 158 | subQuery :: (Reflex t, MonadQuery t q2 m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1)) 159 | subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x) 160 | -------------------------------------------------------------------------------- /src/Reflex/Requester/Base.hs: -------------------------------------------------------------------------------- 1 | module Reflex.Requester.Base 2 | ( RequesterT (..) 3 | , runRequesterT 4 | , withRequesterT 5 | , runWithReplaceRequesterTWith 6 | , traverseIntMapWithKeyWithAdjustRequesterTWith 7 | , traverseDMapWithKeyWithAdjustRequesterTWith 8 | , RequesterData 9 | , RequesterDataKey 10 | , traverseRequesterData 11 | , forRequesterData 12 | , requesterDataToList 13 | , singletonRequesterData 14 | , matchResponsesWithRequests 15 | , matchResponseMapWithRequests 16 | , multiEntry 17 | , unMultiEntry 18 | , requesting' 19 | ) where 20 | 21 | import Reflex.Requester.Base.Internal 22 | -------------------------------------------------------------------------------- /src/Reflex/Requester/Class.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'Requester', which indicates that an action can make 2 | -- requests and receive responses to them. Typically, this is used for things 3 | -- like a WebSocket, where it's desirable to collect many potential sources of 4 | -- events and send them over a single channel, then distribute the results back 5 | -- out efficiently to their original request sites. 6 | {-# LANGUAGE CPP #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE RecursiveDo #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | #ifdef USE_REFLEX_OPTIMIZER 14 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 15 | #endif 16 | module Reflex.Requester.Class 17 | ( Requester (..) 18 | , withRequesting 19 | , requestingIdentity 20 | ) where 21 | 22 | import Control.Monad.Fix 23 | import Control.Monad.Identity 24 | import Control.Monad.Reader 25 | import qualified Control.Monad.State.Lazy as Lazy 26 | import Control.Monad.State.Strict 27 | import Data.Kind (Type) 28 | import Reflex.Class 29 | 30 | -- | A 'Requester' action can trigger requests of type @Request m a@ based on 31 | -- 'Event's, and receive responses of type @Response m a@ in return. Note that 32 | -- the @a@ type can vary within the 'Requester' action, but will be linked for a 33 | -- given request. For example, if @Request m@ is 'IO' and @Response m@ is 34 | -- 'Identity', then 'requestingIdentity' has the same type as 35 | -- 'Reflex.PerformEvent.Class.performEvent'. 36 | class (Reflex t, Monad m) => Requester t m | m -> t where 37 | -- | The type of requests that this 'Requester' can emit 38 | type Request m :: Type -> Type 39 | -- | The type of responses that this 'Requester' can receive 40 | type Response m :: Type -> Type 41 | -- | Emit a request whenever the given 'Event' fires, and return responses in 42 | -- the resulting 'Event'. 43 | requesting :: Event t (Request m a) -> m (Event t (Response m a)) 44 | -- | Emit a request whenever the given 'Event' fires, and ignore all responses. 45 | requesting_ :: Event t (Request m a) -> m () 46 | 47 | 48 | instance Requester t m => Requester t (ReaderT r m) where 49 | type Request (ReaderT r m) = Request m 50 | type Response (ReaderT r m) = Response m 51 | requesting = lift . requesting 52 | requesting_ = lift . requesting_ 53 | 54 | instance Requester t m => Requester t (StateT s m) where 55 | type Request (StateT s m) = Request m 56 | type Response (StateT s m) = Response m 57 | requesting = lift . requesting 58 | requesting_ = lift . requesting_ 59 | 60 | instance Requester t m => Requester t (Lazy.StateT s m) where 61 | type Request (Lazy.StateT s m) = Request m 62 | type Response (Lazy.StateT s m) = Response m 63 | requesting = lift . requesting 64 | requesting_ = lift . requesting_ 65 | 66 | -- | Emit a request whenever the given 'Event' fires, and unwrap the responses 67 | -- before returning them. @Response m@ must be 'Identity'. 68 | requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a) 69 | requestingIdentity = fmap coerceEvent . requesting 70 | 71 | withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r 72 | withRequesting f = do 73 | rec response <- requesting request 74 | (request, result) <- f response 75 | return result 76 | -------------------------------------------------------------------------------- /src/Reflex/Spider.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- Module: 4 | -- Reflex.Spider 5 | -- Description: 6 | -- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine 7 | module Reflex.Spider 8 | ( Spider 9 | , SpiderTimeline 10 | , Global 11 | , SpiderHost 12 | , runSpiderHost 13 | , runSpiderHostForTimeline 14 | , newSpiderTimeline 15 | , withSpiderTimeline 16 | -- * Deprecated 17 | , SpiderEnv 18 | ) where 19 | 20 | import Reflex.Spider.Internal 21 | -------------------------------------------------------------------------------- /src/Reflex/TriggerEvent/Base.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'TriggerEventT', the standard implementation of 2 | -- 'TriggerEvent'. 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Reflex.TriggerEvent.Base 10 | ( TriggerEventT (..) 11 | , runTriggerEventT 12 | , askEvents 13 | , TriggerInvocation (..) 14 | , EventTriggerRef (..) 15 | ) where 16 | 17 | import Control.Applicative (liftA2) 18 | import Control.Concurrent 19 | import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) 20 | import Control.Monad.Exception 21 | import Control.Monad.Fix 22 | import Control.Monad.Primitive 23 | import Control.Monad.Reader 24 | import Control.Monad.Ref 25 | import Data.Coerce 26 | import Data.Dependent.Sum 27 | import Data.IORef 28 | import qualified Data.Semigroup as S 29 | import Reflex.Class 30 | import Reflex.Adjustable.Class 31 | import Reflex.Host.Class 32 | import Reflex.PerformEvent.Class 33 | import Reflex.PostBuild.Class 34 | import Reflex.TriggerEvent.Class 35 | 36 | -- | A value with which to fire an 'Event', as well as a callback to invoke 37 | -- after its propagation has completed. 38 | data TriggerInvocation a = TriggerInvocation a (IO ()) 39 | 40 | -- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'. 41 | newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) } 42 | 43 | -- | A basic implementation of 'TriggerEvent'. 44 | newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a } 45 | deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException, MonadCatch, MonadThrow, MonadMask) 46 | 47 | -- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which 48 | -- 'TriggerInvocation's can be passed; it is expected that some other thread 49 | -- will be responsible for popping values out of the 'Chan' and firing their 50 | -- 'EventTrigger's. 51 | runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a 52 | runTriggerEventT = runReaderT . unTriggerEventT 53 | 54 | instance MonadTrans (TriggerEventT t) where 55 | {-# INLINABLE lift #-} 56 | lift = TriggerEventT . lift 57 | 58 | instance PrimMonad m => PrimMonad (TriggerEventT t m) where 59 | type PrimState (TriggerEventT t m) = PrimState m 60 | {-# INLINABLE primitive #-} 61 | primitive = lift . primitive 62 | 63 | instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where 64 | type Performable (TriggerEventT t m) = Performable m 65 | {-# INLINABLE performEvent_ #-} 66 | performEvent_ e = lift $ performEvent_ e 67 | {-# INLINABLE performEvent #-} 68 | performEvent e = lift $ performEvent e 69 | 70 | instance PostBuild t m => PostBuild t (TriggerEventT t m) where 71 | {-# INLINABLE getPostBuild #-} 72 | getPostBuild = lift getPostBuild 73 | 74 | instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where 75 | {-# INLINABLE newEventWithTrigger #-} 76 | newEventWithTrigger = lift . newEventWithTrigger 77 | {-# INLINABLE newFanEventWithTrigger #-} 78 | newFanEventWithTrigger f = lift $ newFanEventWithTrigger f 79 | 80 | instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where 81 | {-# INLINABLE newTriggerEvent #-} 82 | newTriggerEvent = do 83 | (e, t) <- newTriggerEventWithOnComplete 84 | return (e, \a -> t a $ return ()) 85 | {-# INLINABLE newTriggerEventWithOnComplete #-} 86 | newTriggerEventWithOnComplete = do 87 | events <- askEvents 88 | (eResult, reResultTrigger) <- lift newEventWithTriggerRef 89 | return . (,) eResult $ \a cb -> 90 | writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb] 91 | {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-} 92 | newEventWithLazyTriggerWithOnComplete f = do 93 | events <- askEvents 94 | lift . newEventWithTrigger $ \t -> 95 | f $ \a cb -> do 96 | reResultTrigger <- newRef $ Just t 97 | writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb] 98 | 99 | instance MonadRef m => MonadRef (TriggerEventT t m) where 100 | type Ref (TriggerEventT t m) = Ref m 101 | {-# INLINABLE newRef #-} 102 | newRef = lift . newRef 103 | {-# INLINABLE readRef #-} 104 | readRef = lift . readRef 105 | {-# INLINABLE writeRef #-} 106 | writeRef r = lift . writeRef r 107 | 108 | instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where 109 | {-# INLINABLE atomicModifyRef #-} 110 | atomicModifyRef r = lift . atomicModifyRef r 111 | 112 | instance MonadSample t m => MonadSample t (TriggerEventT t m) where 113 | {-# INLINABLE sample #-} 114 | sample = lift . sample 115 | 116 | instance MonadHold t m => MonadHold t (TriggerEventT t m) where 117 | {-# INLINABLE hold #-} 118 | hold v0 v' = lift $ hold v0 v' 119 | {-# INLINABLE holdDyn #-} 120 | holdDyn v0 v' = lift $ holdDyn v0 v' 121 | {-# INLINABLE holdIncremental #-} 122 | holdIncremental v0 v' = lift $ holdIncremental v0 v' 123 | {-# INLINABLE buildDynamic #-} 124 | buildDynamic a0 = lift . buildDynamic a0 125 | {-# INLINABLE headE #-} 126 | headE = lift . headE 127 | {-# INLINABLE now #-} 128 | now = lift now 129 | 130 | instance Adjustable t m => Adjustable t (TriggerEventT t m) where 131 | {-# INLINABLE runWithReplace #-} 132 | runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a') 133 | {-# INLINABLE traverseIntMapWithKeyWithAdjust #-} 134 | traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm' 135 | {-# INLINABLE traverseDMapWithKeyWithAdjust #-} 136 | traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm' 137 | {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-} 138 | traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm' 139 | 140 | -- TODO: Monoid and Semigroup can likely be derived once ReaderT has them. 141 | instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where 142 | mempty = pure mempty 143 | mappend = (<>) 144 | 145 | instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where 146 | (<>) = liftA2 (S.<>) 147 | 148 | 149 | -- | Retrieve the current 'Chan'; event trigger invocations pushed into it will 150 | -- be fired. 151 | askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation]) 152 | askEvents = TriggerEventT ask 153 | -------------------------------------------------------------------------------- /src/Reflex/TriggerEvent/Class.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines 'TriggerEvent', which describes actions that may create 2 | -- new 'Event's that can be triggered from 'IO'. 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module Reflex.TriggerEvent.Class 7 | ( TriggerEvent (..) 8 | ) where 9 | 10 | import Reflex.Class 11 | 12 | import Control.Monad.Reader 13 | import Control.Monad.State 14 | import qualified Control.Monad.State.Strict as Strict 15 | import Control.Monad.Trans.Maybe (MaybeT) 16 | 17 | --TODO: Shouldn't have IO hard-coded 18 | -- | 'TriggerEvent' represents actions that can create 'Event's that can be 19 | -- triggered by 'IO' actions. 20 | class Monad m => TriggerEvent t m | m -> t where 21 | -- | Create a triggerable 'Event'. Whenever the resulting function is called, 22 | -- the resulting 'Event' will fire at some point in the future. Note that 23 | -- this may not be synchronous. 24 | newTriggerEvent :: m (Event t a, a -> IO ()) 25 | -- | Like 'newTriggerEvent', but the callback itself takes another callback, 26 | -- to be invoked once the requested 'Event' occurrence has finished firing. 27 | -- This allows synchronous operation. 28 | newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow 29 | -- | Like 'newTriggerEventWithOnComplete', but with setup and teardown. This 30 | -- relatively complex type signature allows any external listeners to be 31 | -- subscribed lazily and then removed whenever the returned 'Event' is no 32 | -- longer being listened to. Note that the setup/teardown may happen multiple 33 | -- times, and there is no guarantee that the teardown will be executed 34 | -- promptly, or even at all, in the case of program termination. 35 | newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a) 36 | 37 | instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where 38 | newTriggerEvent = lift newTriggerEvent 39 | newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete 40 | newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete 41 | 42 | instance TriggerEvent t m => TriggerEvent t (StateT s m) where 43 | newTriggerEvent = lift newTriggerEvent 44 | newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete 45 | newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete 46 | 47 | instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where 48 | newTriggerEvent = lift newTriggerEvent 49 | newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete 50 | newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete 51 | 52 | instance TriggerEvent t m => TriggerEvent t (MaybeT m) where 53 | newTriggerEvent = lift newTriggerEvent 54 | newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete 55 | newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete 56 | -------------------------------------------------------------------------------- /src/Reflex/Widget/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ExplicitForAll #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | #ifdef USE_REFLEX_OPTIMIZER 6 | {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} 7 | #endif 8 | 9 | module Reflex.Widget.Basic where 10 | 11 | import Control.Monad.Fix (MonadFix) 12 | import Data.Map (Map) 13 | 14 | import Reflex.Class 15 | import Reflex.Adjustable.Class 16 | import Data.Patch.MapWithMove 17 | 18 | 19 | -- | Build sortable content in such a way that re-sorting it can cause minimal 20 | -- disruption to an existing context. 21 | -- 22 | -- Naively re-sorting a list of images would destroy every image and add them back 23 | -- in the new order. This framework is able to avoid that by preserving the 24 | -- identity of each image and simply moving it to the new location. 25 | -- 26 | -- Example: 27 | -- 28 | -- > let sortByFst = buttonA $> comparing fst 29 | -- > sortBySnd = buttonB $> comparing snd 30 | -- > sortEvent = leftmost [sortByFst, sortBySnd] 31 | -- > sortableList 32 | -- > (\k v -> text $ "\n" ++ show k ++ " " ++ v) -- show each element on a new line 33 | -- > (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")]) 34 | -- > sortEvent 35 | sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, Adjustable t m, Ord k) 36 | => (k -> v -> m a) -- ^ Function to render the content for each key/value pair 37 | -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order 38 | -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list 39 | -> m (Map k a) 40 | sortableList f m0 reSortFunc = do 41 | rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc 42 | m <- holdIncremental m0 reSortPatch 43 | (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch 44 | pure results 45 | -------------------------------------------------------------------------------- /src/Reflex/Workflow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | -- | 4 | -- Module: 5 | -- Reflex.Workflow 6 | -- Description: 7 | -- Provides a convenient way to describe a series of interrelated widgets that 8 | -- can send data to, invoke, and replace one another. Useful for modeling user interface 9 | -- "workflows." 10 | module Reflex.Workflow ( 11 | Workflow (..) 12 | , workflow 13 | , workflowView 14 | , mapWorkflow 15 | , mapWorkflowCheap 16 | ) where 17 | 18 | import Control.Arrow ((***)) 19 | import Control.Monad.Fix (MonadFix) 20 | 21 | import Reflex.Class 22 | import Reflex.Adjustable.Class 23 | import Reflex.Network 24 | import Reflex.NotReady.Class 25 | import Reflex.PostBuild.Class 26 | 27 | -- | A widget in a workflow 28 | -- 29 | -- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type. 30 | newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } 31 | 32 | -- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another). 33 | workflow :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) 34 | workflow w0 = do 35 | rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult 36 | return $ fmap fst eResult 37 | 38 | -- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'. 39 | workflowView :: forall t m a. (NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) 40 | workflowView w0 = do 41 | rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace 42 | eReplace <- fmap switch $ hold never $ fmap snd eResult 43 | return $ fmap fst eResult 44 | 45 | -- | Map a function over a 'Workflow', possibly changing the return type. 46 | mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b 47 | mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x) 48 | 49 | -- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations. 50 | mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b 51 | mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x) 52 | -------------------------------------------------------------------------------- /stylize: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | for x in **/*.hs ; do stylish-haskell -i "$x" ; done 5 | -------------------------------------------------------------------------------- /test/Adjustable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecursiveDo #-} 5 | 6 | module Main where 7 | 8 | import Control.Monad.Fix 9 | import Data.Maybe 10 | import qualified Data.Map as Map 11 | 12 | import Reflex 13 | import Reflex.EventWriter.Base 14 | import Reflex.Network 15 | import Reflex.Patch.MapWithMove 16 | import Test.Run 17 | 18 | main :: IO () 19 | main = do 20 | let actions = [ Increment, Update0th, Increment, Swap, Increment, Increment ] 21 | os <- runAppB testPatchMapWithMove $ map Just actions 22 | -- If the final counter value in the adjusted widgets corresponds to the number of times it has 23 | -- been incremented, we know that the networks haven't broken. 24 | let expectedCount = length $ ffilter (== Increment) actions 25 | -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved 26 | return () 27 | 28 | data PatchMapTestAction 29 | = Increment 30 | | Swap 31 | | Update0th 32 | deriving Eq 33 | 34 | -- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing. 35 | testPatchMapWithMove 36 | :: forall t m 37 | . ( Reflex t 38 | , Adjustable t m 39 | , MonadHold t m 40 | , MonadFix m 41 | ) 42 | => Event t PatchMapTestAction 43 | -> m (Behavior t [Int]) 44 | testPatchMapWithMove pulse = do 45 | let pulseAction = ffor pulse $ \case 46 | Increment -> Nothing 47 | Swap -> patchMapWithMove $ Map.fromList 48 | [ (0, NodeInfo (From_Move 1) (Just 1)) 49 | , (1, NodeInfo (From_Move 0) (Just 0)) 50 | ] 51 | Update0th -> patchMapWithMove $ Map.fromList 52 | [ (0, NodeInfo (From_Insert 'z') Nothing) ] 53 | (_, result) <- runBehaviorWriterT $ mdo 54 | counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction 55 | _ <- mapMapWithAdjustWithMove 56 | (\_ _ -> networkHold 57 | (tellBehavior $ constant []) 58 | ((\t -> tellBehavior $ constant [t]) <$> updated counter)) 59 | (Map.fromList $ zip [0..] "ab") 60 | (fmapMaybe id pulseAction) 61 | return () 62 | return result -------------------------------------------------------------------------------- /test/DebugCycles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RecursiveDo #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | 10 | module Main where 11 | 12 | import Data.Foldable 13 | import Control.Lens 14 | import Control.Applicative 15 | import Control.Monad 16 | import Control.Monad.Fix 17 | import Control.Exception 18 | import System.Timeout 19 | import Data.Maybe (isJust) 20 | import Data.Functor.Misc 21 | import qualified Data.Map as Map 22 | import Data.Map (Map) 23 | import qualified Data.IntMap as IntMap 24 | import Data.IntMap (IntMap) 25 | import Data.These 26 | import Data.Align 27 | import Reflex 28 | import Reflex.EventWriter.Base 29 | import Test.Run 30 | import Test.Hspec 31 | import Reflex.Spider.Internal (EventLoopException) 32 | import Witherable (Filterable) 33 | 34 | #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) 35 | import Data.These.Lens 36 | #endif 37 | 38 | type Widget t m = (MonadHold t m, Reflex t, MonadFix m) 39 | 40 | connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a) 41 | connectDyn e (d, d') = do 42 | dd <- holdDyn d (d' <$ e) 43 | return $ join dd 44 | 45 | dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 46 | dynLoop (e1, e2) = do 47 | -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}" 48 | rec 49 | d <- count e1 50 | d' <- connectDyn e2 (d, liftA2 (+) d d') 51 | return $ updated d' 52 | 53 | connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a) 54 | connectOnCoincidence click e = do 55 | d <- holdDyn never (e <$ click) 56 | return $ coincidence (updated d) 57 | 58 | coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 59 | coincidenceLoop (e1, e2) = do 60 | -- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}" 61 | -- (simpler version of dynLoop) 62 | rec 63 | e' <- connectOnCoincidence e2 (updated d) 64 | d <- count (align e' e1) 65 | return $ updated d 66 | 67 | addHeight :: Reflex t => Event t a -> Event t a 68 | addHeight e = leftmost [e4, e4] where 69 | e1 = leftmost [e, e] 70 | e2 = leftmost [e1, e1] 71 | e3 = leftmost [e2, e2] 72 | e4 = leftmost [e3, e3] 73 | 74 | -- Take an existing test and build it inside a 75 | buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int) 76 | buildLoop test (e1, e2) = switchHold never buildLoop 77 | where buildLoop = pushAlways (const $ test (e1, e2)) e2 78 | 79 | connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a) 80 | connectButtonPromptly click e = do 81 | d <- holdDyn never (e <$ click) 82 | return (switchDyn d) 83 | 84 | connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a) 85 | connectButton click e = do 86 | d <- hold never (e <$ click) 87 | return (switch d) 88 | 89 | switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 90 | switchLoop01 (e1, e2) = do 91 | rec 92 | e' <- connectButton e2 (updated d) 93 | d <- count (align e' e1) 94 | return $ updated d 95 | 96 | mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int) 97 | mergeLoop (e1, e2) = do 98 | rec 99 | (_, e) <- runEventWriterT $ 100 | runWithReplace w (leftmost [w <$ e1]) 101 | return (sum <$> e) 102 | where 103 | w = do 104 | c <- count e1 105 | tellEvent (updated ((pure <$> c) :: Dynamic t [Int])) 106 | 107 | switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 108 | switchLoop02 (e1, e2) = do 109 | rec 110 | e' <- connectButton e2 (updated d) 111 | d <- count (leftmost [e', e1]) 112 | return $ updated d 113 | 114 | switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 115 | switchLoop03 (e1, e2) = do 116 | rec 117 | e' <- connectButton e2 (addHeight $ updated d) 118 | d <- count (align e' e1) 119 | return $ updated d 120 | 121 | staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 122 | staticLoop01 (e1, e2) = do 123 | rec 124 | d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d)) 125 | return $ updated d 126 | 127 | staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 128 | staticLoop02 (e1, e2) = do 129 | rec 130 | d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d]) 131 | return $ updated d 132 | 133 | buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int) 134 | buildStaticLoop (e1, e2) = switchHold never buildLoop 135 | where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2 136 | 137 | splitThese :: Filterable f => f (These a b) -> (f a, f b) 138 | splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f) 139 | 140 | main :: IO () 141 | main = hspec $ do 142 | describe "DebugCycles" $ do 143 | it "throws EventLoopException on switchLoop01" $ do 144 | check switchLoop01 145 | it "throws EventLoopException on switchLoop02" $ do 146 | check switchLoop02 147 | it "throws EventLoopException on switchLoop03" $ do 148 | check switchLoop03 149 | it "throws EventLoopException on buildSwitchLoop" $ do 150 | check $ buildLoop switchLoop01 151 | xit "throws EventLoopException on mergeLoop" $ do 152 | check mergeLoop 153 | xit "throws EventLoopException on staticLoop01" $ do 154 | check staticLoop01 155 | xit "throws EventLoopException on staticLoop02" $ do 156 | check staticLoop02 157 | xit "throws EventLoopException on buildStaticLoop" $ do 158 | check buildStaticLoop 159 | xit "throws EventLoopException on coincidenceLoop" $ do 160 | check coincidenceLoop 161 | xit "throws EventLoopException on dynLoop" $ do 162 | check dynLoop 163 | xit "throws EventLoopException on buildCoincidenceLoop" $ do 164 | check $ buildLoop coincidenceLoop 165 | where 166 | milliseconds = (*1000) 167 | occs = [ This 1, This 2, That (), This 3, That (), This 1 ] 168 | check test = do 169 | let action = timeout (milliseconds 50) $ do 170 | runApp' (test . splitThese) (Just <$> occs) 171 | action `shouldThrow` (const True :: Selector EventLoopException) 172 | -------------------------------------------------------------------------------- /test/EventWriterT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE RecursiveDo #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | module Main where 8 | 9 | import Control.Lens 10 | import Control.Monad 11 | import Control.Monad.Fix 12 | import qualified Data.Dependent.Map as DMap 13 | import Data.Functor.Misc 14 | import qualified Data.Map as M 15 | import Data.These 16 | 17 | #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) 18 | import Data.These.Lens 19 | #endif 20 | 21 | import Reflex 22 | import Reflex.EventWriter.Base 23 | import Test.Run 24 | 25 | main :: IO () 26 | main = do 27 | os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $ 28 | [ Just () 29 | ] 30 | print os1 31 | os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] 32 | <- runApp' (unwrapApp testSimultaneous) $ map Just $ 33 | [ This () 34 | , That () 35 | , This () 36 | , These () () 37 | ] 38 | print os2 39 | os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()] 40 | print os3 41 | os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()] 42 | print os4 43 | os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()] 44 | print os5 45 | os6 <- runApp' (unwrapApp delayedPulse) [Just ()] 46 | print os6 47 | let ![[Nothing, Nothing]] = os6 48 | return () 49 | 50 | unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int]) 51 | unwrapApp x appIn = do 52 | ((), e) <- runEventWriterT $ x appIn 53 | return e 54 | 55 | testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m () 56 | testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse) 57 | 58 | testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m () 59 | testSimultaneous pulse = do 60 | let e0 = fmapMaybe (^? here) pulse 61 | e1 = fmapMaybe (^? there) pulse 62 | forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0) 63 | 64 | -- | Test that a widget telling and event which fires at the same time it has been replaced 65 | -- doesn't count along with the new widget. 66 | testMoribundTellEvent 67 | :: forall t m 68 | . ( Reflex t 69 | , Adjustable t m 70 | , MonadHold t m 71 | , MonadFix m 72 | ) 73 | => Event t () 74 | -> EventWriterT t [Int] m () 75 | testMoribundTellEvent pulse = do 76 | rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () 77 | tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished 78 | (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse 79 | return () 80 | 81 | -- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'. 82 | testMoribundTellEventDMap 83 | :: forall t m 84 | . ( Reflex t 85 | , Adjustable t m 86 | , MonadHold t m 87 | , MonadFix m 88 | ) 89 | => Event t () 90 | -> EventWriterT t [Int] m () 91 | testMoribundTellEventDMap pulse = do 92 | rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () 93 | tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished 94 | (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <- 95 | traverseDMapWithKeyWithAdjust 96 | (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v) 97 | (mapToDMap $ M.singleton () 1) 98 | ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse) 99 | return () 100 | 101 | -- | Ensures that elements which are _not_ removed can still fire 'tellEvent's 102 | -- during the same frame as other elements are updated. 103 | testLiveTellEventDMap 104 | :: forall t m 105 | . ( Reflex t 106 | , Adjustable t m 107 | , MonadHold t m 108 | , MonadFix m 109 | ) 110 | => Event t () 111 | -> EventWriterT t [Int] m () 112 | testLiveTellEventDMap pulse = do 113 | rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () 114 | tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished 115 | (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <- 116 | traverseDMapWithKeyWithAdjust 117 | (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k) 118 | (mapToDMap $ M.singleton 1 ()) 119 | ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) 120 | return () 121 | 122 | delayedPulse 123 | :: forall t m 124 | . ( Reflex t 125 | , Adjustable t m 126 | , MonadHold t m 127 | , MonadFix m 128 | ) 129 | => Event t () 130 | -> EventWriterT t [Int] m () 131 | delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do 132 | -- This has the effect of delaying pulse' from pulse 133 | (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse 134 | tellEvent pulse' 135 | -------------------------------------------------------------------------------- /test/GC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | module Main where 8 | 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Control.Monad.Ref 12 | import Data.Align 13 | import Data.Dependent.Map (DMap) 14 | import qualified Data.Dependent.Map as DMap 15 | import Data.Dependent.Sum 16 | import Data.Functor.Identity 17 | import Data.GADT.Compare 18 | import Data.IORef 19 | import Data.Semigroup 20 | import Data.These 21 | import Data.Type.Equality ((:~:)(Refl)) 22 | 23 | import Data.Functor.Misc 24 | import Data.Patch 25 | 26 | import qualified Reflex.Host.Class as Host 27 | import qualified Reflex.Spider.Internal as S 28 | 29 | import System.Exit 30 | import System.Mem 31 | import Data.Coerce 32 | 33 | main :: IO () 34 | main = do 35 | ref <- newIORef Nothing 36 | hostPerf ref 37 | readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show) 38 | 39 | hostPerf :: IORef (Maybe Int) -> IO () 40 | hostPerf ref = S.runSpiderHost $ do 41 | ---- body 42 | liftIO $ putStrLn "#creating triggers" 43 | (response', responseTrigger) <- Host.newEventWithTriggerRef 44 | (eadd', addTriggerRef) <- Host.newEventWithTriggerRef 45 | let response = S.unSpiderEvent response' 46 | eadd = S.unSpiderEvent eadd' 47 | liftIO $ putStrLn "#creating event graph" 48 | eventToPerform <- Host.runHostFrame $ do 49 | (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity)) 50 | <- S.SpiderHostFrame 51 | $ fmap ( S.mergeG coerce 52 | . S.dynamicHold) 53 | $ S.hold DMap.empty 54 | -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained 55 | $ (\e -> S.Event $ \sub -> do 56 | (s, o) <- S.subscribeAndRead e $ sub 57 | { S.subscriberPropagate = S.subscriberPropagate sub 58 | } 59 | return (s, o)) 60 | $ runIdentity . runIdentity <$> S.selectG 61 | (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) 62 | (WrapArg Request) 63 | return $ alignWith (mergeThese (<>)) 64 | (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do 65 | liftIO $ putStrLn "#eadd fired" 66 | return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just 67 | $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd) 68 | (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m) 69 | ---- epilogue 70 | eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform) 71 | liftIO $ putStrLn "#performing GC" >> performMajorGC 72 | liftIO $ putStrLn "#attempting to fire eadd" 73 | mAddTrigger <- readRef addTriggerRef 74 | forM_ mAddTrigger $ \t -> replicateM_ 2 $ do 75 | liftIO $ putStrLn "#firing eadd" 76 | mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle 77 | case mToPerform of 78 | Nothing -> return () 79 | Just toPerform -> do 80 | responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform 81 | mrt <- readRef responseTrigger 82 | let followupEventTriggers = case mrt of 83 | Just rt -> [rt :=> Identity responses] 84 | Nothing -> [] 85 | Host.fireEventsAndRead followupEventTriggers $ return () 86 | return () 87 | 88 | data Tell a where 89 | Action :: Tell () 90 | Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global)) 91 | 92 | instance GEq Tell where 93 | geq Action Action = Just Refl 94 | geq Request Request = Just Refl 95 | geq _ _ = Nothing 96 | 97 | instance GCompare Tell where 98 | gcompare Action Action = GEQ 99 | gcompare Request Request = GEQ 100 | gcompare Action Request = GLT 101 | gcompare Request Action = GGT 102 | -------------------------------------------------------------------------------- /test/Headless.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Reflex 4 | import Reflex.Host.Headless (runHeadlessApp) 5 | 6 | main :: IO () 7 | main = do 8 | runHeadlessApp $ do 9 | pb <- getPostBuild 10 | performEvent (pure <$> pb) 11 | -------------------------------------------------------------------------------- /test/QueryT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | import Control.Lens 12 | import Control.Monad.Fix 13 | import Data.Align 14 | import qualified Data.AppendMap as AMap 15 | import Data.Functor.Misc 16 | import Data.Map (Map) 17 | import qualified Data.Map as Map 18 | import Data.Map.Monoidal (MonoidalMap) 19 | import Data.Semigroup 20 | import Data.Semigroup.Commutative 21 | import Data.These 22 | 23 | #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) 24 | import Data.These.Lens 25 | #endif 26 | 27 | import Reflex 28 | import Data.Patch.MapWithMove 29 | import Test.Run 30 | 31 | newtype MyQuery = MyQuery SelectedCount 32 | deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Commutative, Group) 33 | 34 | instance Query MyQuery where 35 | type QueryResult MyQuery = () 36 | crop _ _ = () 37 | 38 | instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where 39 | type QueryResult (Selector k a) = Selector k (QueryResult a) 40 | crop q r = undefined 41 | 42 | newtype Selector k a = Selector { unSelector :: MonoidalMap k a } 43 | deriving (Show, Read, Eq, Ord, Functor) 44 | 45 | #if !(MIN_VERSION_monoidal_containers(0,4,1)) 46 | deriving instance Ord k => Align (MonoidalMap k) 47 | #endif 48 | 49 | instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where 50 | (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b 51 | where 52 | f = alignWith $ \case 53 | This x -> Just x 54 | That y -> Just y 55 | These x y -> 56 | let z = x `mappend` y 57 | in if z == mempty then Nothing else Just z 58 | 59 | instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where 60 | mempty = Selector AMap.empty 61 | mappend = (<>) 62 | 63 | instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where 64 | negateG = fmap negateG 65 | 66 | instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Commutative (Selector k a) 67 | 68 | main :: IO () 69 | main = do 70 | [0, 1, 1, 0] <- fmap (map fst . concat) $ 71 | runApp (testQueryT testRunWithReplace) () $ map (Just . That) $ 72 | [ That (), This (), That () ] 73 | [0, 1, 1, 0] <- fmap (map fst . concat) $ 74 | runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $ 75 | [ That (), This (), That () ] 76 | [0, 1, 1, 0] <- fmap (map fst . concat) $ 77 | runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $ 78 | [ That (), This (), That () ] 79 | return () 80 | 81 | testQueryT :: (Reflex t, MonadFix m) 82 | => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ()) 83 | -> AppIn t () (These () ()) 84 | -> m (AppOut t Int Int) 85 | testQueryT w (AppIn _ pulse) = do 86 | let replace = fmapMaybe (^? here) pulse 87 | increment = fmapMaybe (^? there) pulse 88 | (_, q) <- runQueryT (w replace increment) $ pure mempty 89 | let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q 90 | return $ AppOut 91 | { _appOut_behavior = current qDyn 92 | , _appOut_event = updated qDyn 93 | } 94 | 95 | testRunWithReplace :: ( Reflex t 96 | , Adjustable t m 97 | , MonadHold t m 98 | , MonadFix m 99 | , MonadQuery t (Selector Int MyQuery) m) 100 | => Event t () 101 | -> Event t () 102 | -> m () 103 | testRunWithReplace replace increment = do 104 | let w = do 105 | n <- count increment 106 | queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1 107 | _ <- runWithReplace w $ w <$ replace 108 | return () 109 | 110 | testSequenceDMapWithAdjust :: ( Reflex t 111 | , Adjustable t m 112 | , MonadHold t m 113 | , MonadFix m 114 | , MonadQuery t (Selector Int MyQuery) m) 115 | => Event t () 116 | -> Event t () 117 | -> m () 118 | testSequenceDMapWithAdjust replace increment = do 119 | _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do 120 | n <- count increment 121 | queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1 122 | return () 123 | 124 | testSequenceDMapWithAdjustWithMove :: ( Reflex t 125 | , Adjustable t m 126 | , MonadHold t m 127 | , MonadFix m 128 | , MonadQuery t (Selector Int MyQuery) m) 129 | => Event t () 130 | -> Event t () 131 | -> m () 132 | testSequenceDMapWithAdjustWithMove replace increment = do 133 | _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do 134 | n <- count increment 135 | queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1 136 | return () 137 | 138 | -- scam it out to test traverseDMapWithAdjustWithMove 139 | listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, Adjustable t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a)) 140 | listHoldWithKeyWithMove m0 m' f = do 141 | (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing) 142 | incrementalToDynamic <$> holdIncremental n0 n' 143 | -- -} 144 | -------------------------------------------------------------------------------- /test/Reflex/Plan/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | module Reflex.Plan.Pure where 10 | 11 | import Reflex 12 | import Reflex.Pure 13 | import Reflex.TestPlan 14 | 15 | import Control.Applicative 16 | import Control.Monad.Fix 17 | import Control.Monad.State 18 | import Data.IntMap (IntMap) 19 | import qualified Data.IntMap as IntMap 20 | import Data.IntSet (IntSet) 21 | import qualified Data.IntSet as IntSet 22 | 23 | import Data.Bifunctor 24 | import Data.Maybe 25 | import Data.Monoid 26 | import Prelude 27 | 28 | 29 | mapToPureEvent :: IntMap a -> Event (Pure Int) a 30 | mapToPureEvent m = Event $ flip IntMap.lookup m 31 | 32 | type TimeM = (->) Int 33 | newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix) 34 | 35 | liftPlan :: TimeM a -> PurePlan a 36 | liftPlan = PurePlan . lift 37 | 38 | instance MonadHold (Pure Int) PurePlan where 39 | hold initial = liftPlan . hold initial 40 | holdDyn initial = liftPlan . holdDyn initial 41 | holdIncremental initial = liftPlan . holdIncremental initial 42 | buildDynamic getInitial = liftPlan . buildDynamic getInitial 43 | headE = liftPlan . headE 44 | now = liftPlan now 45 | 46 | instance MonadSample (Pure Int) PurePlan where 47 | sample = liftPlan . sample 48 | 49 | 50 | instance TestPlan (Pure Int) PurePlan where 51 | plan occs = do 52 | PurePlan . modify $ IntSet.union (IntMap.keysSet m) 53 | return $ mapToPureEvent m 54 | where m = IntMap.fromList (first fromIntegral <$> occs) 55 | 56 | runPure :: PurePlan a -> (a, IntSet) 57 | runPure (PurePlan p) = runStateT p mempty $ 0 58 | 59 | relevantTimes :: IntSet -> IntSet 60 | relevantTimes occs = IntSet.fromList [0..l + 1] 61 | where l = fromMaybe 0 (fst <$> IntSet.maxView occs) 62 | 63 | testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a 64 | testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs) 65 | 66 | testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a) 67 | testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs) 68 | 69 | 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /test/Reflex/Plan/Reflex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | module Reflex.Plan.Reflex 12 | ( TestPlan(..) 13 | , runPlan 14 | , Plan (..) 15 | , Schedule 16 | , Firing (..) 17 | , MonadIORef 18 | 19 | 20 | , readSchedule 21 | , readSchedule_ 22 | , testSchedule 23 | , readEvent' 24 | , makeDense 25 | 26 | , runTestE 27 | , runTestB 28 | 29 | ) where 30 | 31 | import Reflex.Class 32 | import Reflex.Host.Class 33 | import Reflex.TestPlan 34 | 35 | import Control.Applicative 36 | import Control.Monad 37 | import Control.Monad.Fix 38 | import Control.Monad.Identity 39 | import Control.Monad.State.Strict 40 | 41 | import Control.Monad.Ref 42 | import Data.Dependent.Sum (DSum (..)) 43 | import qualified Data.IntMap.Strict as IntMap 44 | import Data.Maybe 45 | import Data.Monoid 46 | import Data.Traversable (sequenceA, traverse) 47 | 48 | import Control.DeepSeq 49 | import Control.Exception 50 | import Data.IntMap.Strict (IntMap) 51 | import Data.IORef 52 | import System.Mem 53 | 54 | -- Note: this import must come last to silence warnings from AMP 55 | import Prelude 56 | 57 | type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO) 58 | 59 | data Firing t where 60 | Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t 61 | 62 | 63 | type Schedule t = IntMap [Firing t] 64 | 65 | -- Implementation of a TestPlan in terms of ReflexHost 66 | newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a) 67 | 68 | deriving instance ReflexHost t => Functor (Plan t) 69 | deriving instance ReflexHost t => Applicative (Plan t) 70 | deriving instance ReflexHost t => Monad (Plan t) 71 | 72 | deriving instance ReflexHost t => MonadSample t (Plan t) 73 | deriving instance ReflexHost t => MonadHold t (Plan t) 74 | deriving instance ReflexHost t => MonadFix (Plan t) 75 | 76 | 77 | instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where 78 | plan occurrences = Plan $ do 79 | (e, ref) <- newEventWithTriggerRef 80 | modify (IntMap.unionWith mappend (firings ref)) 81 | return e 82 | 83 | where 84 | firings ref = IntMap.fromList (makeFiring ref <$> occurrences) 85 | makeFiring ref (t, a) = (fromIntegral t, [Firing ref a]) 86 | 87 | 88 | firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity)) 89 | firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref 90 | 91 | runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t) 92 | runPlan (Plan p) = runHostFrame $ runStateT p mempty 93 | 94 | 95 | makeDense :: Schedule t -> Schedule t 96 | makeDense s = fromMaybe (emptyRange 0) $ do 97 | (end, _) <- fst <$> IntMap.maxViewWithKey s 98 | return $ IntMap.union s (emptyRange end) 99 | where 100 | emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat [])) 101 | 102 | 103 | -- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors 104 | -- after the last event) 105 | -- performGC is called at each frame to test for GC issues 106 | testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a) 107 | testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule) 108 | 109 | readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a) 110 | readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule 111 | 112 | readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m () 113 | readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule 114 | 115 | triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a 116 | triggerFrame readResult _ occs = do 117 | triggers <- catMaybes <$> traverse firingTrigger occs 118 | liftIO . evaluate . force =<< fireEventsAndRead triggers readResult 119 | 120 | readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a) 121 | readEvent' = readEvent >=> sequenceA 122 | 123 | 124 | -- Convenience functions for running tests producing Events/Behaviors 125 | runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a) 126 | runTestB p = do 127 | (b, s) <- runPlan p 128 | testSchedule s $ sample b 129 | 130 | runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a)) 131 | runTestE p = do 132 | (e, s) <- runPlan p 133 | h <- subscribeEvent e 134 | testSchedule s (readEvent' h) 135 | 136 | 137 | -------------------------------------------------------------------------------- /test/Reflex/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | 8 | module Reflex.Test 9 | ( testAgreement 10 | , compareResult 11 | , runTests 12 | 13 | , module Reflex.TestPlan 14 | 15 | ) where 16 | 17 | import Reflex.Spider 18 | 19 | import Reflex.TestPlan 20 | 21 | import Reflex.Plan.Pure 22 | import Reflex.Plan.Reflex 23 | 24 | import Control.Monad 25 | import Data.Monoid 26 | 27 | import Data.IntMap (IntMap) 28 | 29 | --import Data.Foldable 30 | import System.Exit 31 | 32 | import Prelude 33 | 34 | 35 | testAgreement :: TestCase -> IO Bool 36 | testAgreement (TestE p) = do 37 | spider <- runSpiderHost $ runTestE p 38 | let results = [("spider", spider)] 39 | 40 | compareResult results (testEvent $ runPure p) 41 | 42 | testAgreement (TestB p) = do 43 | spider <- runSpiderHost $ runTestB p 44 | let results = [("spider", spider)] 45 | 46 | compareResult results (testBehavior $ runPure p) 47 | 48 | 49 | compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool 50 | compareResult results expected = fmap and $ forM results $ \(name, r) -> do 51 | 52 | when (r /= expected) $ do 53 | putStrLn ("Got: " ++ show (name, r)) 54 | putStrLn ("Expected: " ++ show expected) 55 | return (r == expected) 56 | 57 | 58 | runTests :: [(String, TestCase)] -> IO () 59 | runTests testCases = do 60 | results <- forM testCases $ \(name, test) -> do 61 | putStrLn $ "Test: " <> name 62 | testAgreement test 63 | exitWith $ if and results 64 | then ExitSuccess 65 | else ExitFailure 1 66 | 67 | -------------------------------------------------------------------------------- /test/Reflex/TestPlan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | module Reflex.TestPlan 10 | ( TestPlan(..) 11 | 12 | , TestCase (..) 13 | , testE, testB 14 | , TestE, TestB 15 | 16 | , planList 17 | 18 | ) where 19 | 20 | import Control.DeepSeq 21 | import Control.Monad.Fix 22 | import Data.Word 23 | import Reflex.Class 24 | 25 | 26 | import Prelude 27 | 28 | class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where 29 | -- | Specify a plan of an input Event firing 30 | -- Occurrences must be in the future (i.e. Time > 0) 31 | -- Initial specification is 32 | 33 | plan :: [(Word, a)] -> m (Event t a) 34 | 35 | 36 | planList :: TestPlan t m => [a] -> m (Event t a) 37 | planList xs = plan $ zip [1..] xs 38 | 39 | type TestE a = forall t m. TestPlan t m => m (Event t a) 40 | type TestB a = forall t m. TestPlan t m => m (Behavior t a) 41 | 42 | data TestCase where 43 | TestE :: (Show a, Eq a, NFData a) => TestE a -> TestCase 44 | TestB :: (Show a, Eq a, NFData a) => TestB a -> TestCase 45 | 46 | -- Helpers to declare test cases 47 | testE :: (Eq a, Show a, NFData a) => String -> TestE a -> (String, TestCase) 48 | testE name test = (name, TestE test) 49 | 50 | testB :: (Eq a, Show a, NFData a) => String -> TestB a -> (String, TestCase) 51 | testB name test = (name, TestB test) 52 | 53 | -------------------------------------------------------------------------------- /test/RequesterT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE RecursiveDo #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | module Main where 15 | 16 | import Control.Lens hiding (has) 17 | import Control.Monad 18 | import Control.Monad.Fix 19 | import Control.Monad.IO.Class (MonadIO) 20 | import Data.Constraint.Extras 21 | import Data.Constraint.Extras.TH 22 | import Data.Constraint.Forall 23 | import qualified Data.Dependent.Map as DMap 24 | import Data.Dependent.Sum 25 | import Data.Functor.Misc 26 | import Data.List (words) 27 | import Data.Map (Map) 28 | import qualified Data.Map as M 29 | #if !MIN_VERSION_these(4,11,0) 30 | import Data.Semigroup ((<>)) 31 | #endif 32 | import Data.Text (Text) 33 | import Data.These 34 | import Text.Read (readMaybe) 35 | 36 | #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) 37 | import Data.These.Lens 38 | #endif 39 | 40 | import Reflex 41 | import Reflex.Requester.Base 42 | import Reflex.Requester.Class 43 | import Test.Run 44 | 45 | data RequestInt a where 46 | RequestInt :: Int -> RequestInt Int 47 | 48 | data TestRequest a where 49 | TestRequest_Reverse :: String -> TestRequest String 50 | TestRequest_Increment :: Int -> TestRequest Int 51 | 52 | deriveArgDict ''TestRequest 53 | 54 | instance Show (TestRequest a) where 55 | show = \case 56 | TestRequest_Reverse str -> "reverse " <> str 57 | TestRequest_Increment i -> "increment " <> show i 58 | 59 | main :: IO () 60 | main = do 61 | os1 <- runApp' (unwrapApp testOrdering) $ 62 | [ Just () 63 | ] 64 | print os1 65 | os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $ 66 | [ This () 67 | , That () 68 | , This () 69 | , These () () 70 | ] 71 | print os2 72 | os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()] 73 | print os3 74 | os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()] 75 | print os4 76 | os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()] 77 | print os5 78 | os6 <- runApp' (unwrapApp delayedPulse) [Just ()] 79 | print os6 80 | os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ] 81 | print os7 82 | os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ] 83 | print os8 84 | let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT' 85 | let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2 86 | let ![[Nothing, Just [2]]] = os3 87 | let ![[Nothing, Just [2]]] = os4 88 | let ![[Nothing, Just [1, 2]]] = os5 89 | -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved 90 | let !(Just [(1,"2")]) = M.toList <$> head (head os7) 91 | let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8) 92 | 93 | return () 94 | 95 | unwrapRequest :: DSum tag RequestInt -> Int 96 | unwrapRequest (_ :=> RequestInt i) = i 97 | 98 | unwrapApp :: ( Reflex t, Monad m ) 99 | => (a -> RequesterT t RequestInt Identity m ()) 100 | -> a 101 | -> m (Event t [Int]) 102 | unwrapApp x appIn = do 103 | ((), e) <- runRequesterT (x appIn) never 104 | return $ fmap (map unwrapRequest . requesterDataToList) e 105 | 106 | testOrdering :: ( Response m ~ Identity 107 | , Request m ~ RequestInt 108 | , Requester t m 109 | , Adjustable t m) 110 | => Event t () 111 | -> m () 112 | testOrdering pulse = forM_ [10,9..1] $ \i -> 113 | requestingIdentity (RequestInt i <$ pulse) 114 | 115 | testSimultaneous :: ( Response m ~ Identity 116 | , Request m ~ RequestInt 117 | , Requester t m 118 | , Adjustable t m) 119 | => Event t (These () ()) 120 | -> m () 121 | testSimultaneous pulse = do 122 | let tellE = fmapMaybe (^? here) pulse 123 | switchE = fmapMaybe (^? there) pulse 124 | forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ -> 125 | requestingIdentity (RequestInt (i+1) <$ tellE) 126 | 127 | -- | Test that a widget requesting and event which fires at the same time it has been replaced 128 | -- doesn't count along with the new widget. 129 | testMoribundRequest 130 | :: forall t m 131 | . ( Reflex t 132 | , Adjustable t m 133 | , MonadHold t m 134 | , MonadFix m 135 | , Response m ~ Identity 136 | , Request m ~ RequestInt 137 | , Requester t m 138 | ) 139 | => Event t () 140 | -> m () 141 | testMoribundRequest pulse = do 142 | rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished 143 | (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse 144 | return () 145 | 146 | -- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'. 147 | testMoribundRequestDMap 148 | :: forall t m 149 | . ( Reflex t 150 | , Adjustable t m 151 | , MonadHold t m 152 | , MonadFix m 153 | , Response m ~ Identity 154 | , Request m ~ RequestInt 155 | , Requester t m 156 | ) 157 | => Event t () 158 | -> m () 159 | testMoribundRequestDMap pulse = do 160 | rec let requestIntOnReplace :: Int -> m () 161 | requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished 162 | (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <- 163 | traverseDMapWithKeyWithAdjust 164 | (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v) 165 | (mapToDMap $ M.singleton () 1) 166 | ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse) 167 | return () 168 | 169 | -- | Ensures that elements which are _not_ removed can still fire requests 170 | -- during the same frame as other elements are updated. 171 | testLiveRequestDMap 172 | :: forall t m 173 | . ( Reflex t 174 | , Adjustable t m 175 | , MonadHold t m 176 | , MonadFix m 177 | , Response m ~ Identity 178 | , Request m ~ RequestInt 179 | , Requester t m 180 | ) 181 | => Event t () 182 | -> m () 183 | testLiveRequestDMap pulse = do 184 | rec let requestIntOnReplace :: Int -> m () 185 | requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished 186 | (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <- 187 | traverseDMapWithKeyWithAdjust 188 | (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k) 189 | (mapToDMap $ M.singleton 1 ()) 190 | ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) 191 | return () 192 | 193 | delayedPulse 194 | :: forall t m 195 | . ( Reflex t 196 | , Adjustable t m 197 | , MonadHold t m 198 | , MonadFix m 199 | , Response m ~ Identity 200 | , Request m ~ RequestInt 201 | , PerformEvent t m 202 | , Requester t m 203 | ) 204 | => Event t () 205 | -> m () 206 | delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do 207 | -- This has the effect of delaying pulse' from pulse 208 | (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse 209 | requestingIdentity pulse' 210 | 211 | testMatchRequestsWithResponses 212 | :: forall m t req a 213 | . ( MonadFix m 214 | , MonadHold t m 215 | , Reflex t 216 | , PerformEvent t m 217 | , MonadIO (Performable m) 218 | , ForallF Show req 219 | , Has Read req 220 | ) 221 | => Event t (req a) -> m (Event t (Map Int String)) 222 | testMatchRequestsWithResponses pulse = mdo 223 | (_, requests) <- runRequesterT (requesting pulse) responses 224 | let rawResponses = M.map (\v -> 225 | case words v of 226 | ["reverse", str] -> reverse str 227 | ["increment", i] -> show $ succ $ (read i :: Int) 228 | ) <$> rawRequestMap 229 | (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses) 230 | pure rawResponses 231 | where 232 | reqEncoder :: forall a. req a -> (String, String -> Maybe a) 233 | reqEncoder r = 234 | ( whichever @Show @req @a $ show r 235 | , \x -> has @Read r $ readMaybe x 236 | ) 237 | -------------------------------------------------------------------------------- /test/Test/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Test.Run where 4 | 5 | import Control.Monad 6 | import Control.Monad.Ref 7 | import Data.Dependent.Sum 8 | import Data.Functor.Identity 9 | import Data.These 10 | 11 | import Reflex 12 | import Reflex.Host.Class 13 | 14 | data AppIn t b e = AppIn 15 | { _appIn_behavior :: Behavior t b 16 | , _appIn_event :: Event t e 17 | } 18 | 19 | data AppOut t b e = AppOut 20 | { _appOut_behavior :: Behavior t b 21 | , _appOut_event :: Event t e 22 | } 23 | 24 | runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) 25 | => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut)) 26 | -> bIn 27 | -> [Maybe (These bIn eIn)] 28 | -> IO [[(bOut, Maybe eOut)]] 29 | runApp app b0 input = runSpiderHost $ do 30 | (appInHoldE, pulseHoldTriggerRef) <- newEventWithTriggerRef 31 | (appInE, pulseEventTriggerRef) <- newEventWithTriggerRef 32 | appInB <- hold b0 appInHoldE 33 | (out, FireCommand fire) <- hostPerformEventT $ app $ AppIn 34 | { _appIn_event = appInE 35 | , _appIn_behavior = appInB 36 | } 37 | hnd <- subscribeEvent (_appOut_event out) 38 | mpulseB <- readRef pulseHoldTriggerRef 39 | mpulseE <- readRef pulseEventTriggerRef 40 | let readPhase = do 41 | b <- sample (_appOut_behavior out) 42 | frames <- sequence =<< readEvent hnd 43 | return (b, frames) 44 | forM input $ \case 45 | Nothing -> 46 | fire [] $ readPhase 47 | Just i -> case i of 48 | This b' -> case mpulseB of 49 | Nothing -> error "tried to fire in-behavior but ref was empty" 50 | Just pulseB -> fire [ pulseB :=> Identity b' ] $ readPhase 51 | That e' -> case mpulseE of 52 | Nothing -> error "tried to fire in-event but ref was empty" 53 | Just pulseE -> fire [ pulseE :=> Identity e' ] $ readPhase 54 | These b' e' -> case mpulseB of 55 | Nothing -> error "tried to fire in-behavior but ref was empty" 56 | Just pulseB -> case mpulseE of 57 | Nothing -> error "tried to fire in-event but ref was empty" 58 | Just pulseE -> fire [ pulseB :=> Identity b', pulseE :=> Identity e' ] $ readPhase 59 | 60 | runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) 61 | => (Event t eIn -> PerformEventT t m (Event t eOut)) 62 | -> [Maybe eIn] 63 | -> IO [[Maybe eOut]] 64 | runApp' app input = do 65 | let app' = fmap (AppOut (pure ())) . app 66 | map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input) 67 | 68 | runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) 69 | => (Event t eIn -> PerformEventT t m (Behavior t bOut)) 70 | -> [Maybe eIn] 71 | -> IO [[bOut]] 72 | runAppB app input = do 73 | let app' = fmap (flip AppOut never) . app 74 | map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input) 75 | -------------------------------------------------------------------------------- /test/hlint.hs: -------------------------------------------------------------------------------- 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 | , "--ignore=Replace case with maybe" 25 | , "--cpp-define=USE_TEMPLATE_HASKELL" 26 | , "--cpp-define=DEBUG" 27 | , "--ignore=Use tuple-section" 28 | ] 29 | recurseInto = and <$> sequence 30 | [ fileType ==? Directory 31 | , fileName /=? ".git" 32 | ] 33 | matchFile = and <$> sequence 34 | [ extension ==? ".hs" 35 | ] 36 | files <- find recurseInto matchFile (pwd "src") --TODO: Someday fix all hints in tests, etc. 37 | ideas <- fmap concat $ forM files $ \f -> do 38 | putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... " 39 | runHlint f 40 | if null ideas then exitSuccess else exitFailure 41 | -------------------------------------------------------------------------------- /test/rootCleanup.hs: -------------------------------------------------------------------------------- 1 | import Control.Concurrent 2 | import Control.Monad 3 | import Data.IORef 4 | import Reflex 5 | import Reflex.Host.Class 6 | import System.Exit 7 | import System.Mem 8 | 9 | main :: IO () 10 | main = do 11 | numSubscriptions <- newIORef 0 12 | replicateM_ 1000 $ do 13 | runSpiderHost $ do 14 | e <- newEventWithTrigger $ \_ -> do 15 | modifyIORef' numSubscriptions succ 16 | return $ modifyIORef' numSubscriptions pred 17 | _ <- hold () e 18 | return () 19 | replicateM_ 100 $ do 20 | performMajorGC 21 | threadDelay 1 22 | n <- readIORef numSubscriptions 23 | if n == 0 24 | then putStrLn "Succeeded" 25 | else putStrLn "Failed" >> exitFailure 26 | -------------------------------------------------------------------------------- /test/semantics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | 8 | module Main (main) where 9 | 10 | import Reflex.Test 11 | 12 | import Data.Bifunctor 13 | import Data.Functor 14 | import Data.List 15 | import qualified Reflex.Bench.Focused as Focused 16 | import qualified Reflex.Test.Micro as Micro 17 | 18 | import System.Environment 19 | import System.Exit 20 | 21 | import Prelude 22 | 23 | matchPrefixes :: [String] -> (String -> Bool) 24 | matchPrefixes [] = const True 25 | matchPrefixes args = \name -> any (`isPrefixOf` name) args 26 | 27 | 28 | main :: IO () 29 | main = do 30 | args <- getArgs 31 | 32 | case args of 33 | ["--list"] -> mapM_ putStrLn (fst <$> allTests) >> exitWith (ExitFailure 1) 34 | _ -> case filter (matchPrefixes args . fst) allTests of 35 | [] -> putStrLn "filter did not match any tests" >> exitWith (ExitFailure 1) 36 | tests -> runTests tests 37 | 38 | where 39 | allTests = concat 40 | [ makeGroup "micro" Micro.testCases 41 | , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) 42 | , makeGroup "firing 1000" (Focused.firing 1000) 43 | , makeGroup "merge 100" (Focused.merging 100) 44 | , makeGroup "fan 50" (Focused.fans 50) 45 | ] 46 | 47 | makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests 48 | --------------------------------------------------------------------------------