├── .ghci ├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── .stylish-haskell.yaml ├── CONTRIBUTING.md ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench-cbits └── checkCapability.c ├── cabal.project ├── nix ├── deps │ ├── nix-haskell-ci │ │ ├── default.nix │ │ ├── github.json │ │ └── thunk.nix │ ├── nixpkgs │ │ ├── default.nix │ │ ├── github.json │ │ └── thunk.nix │ └── reflex-platform │ │ ├── default.nix │ │ ├── github.json │ │ └── thunk.nix ├── project │ └── haskell.nix ├── release │ ├── haskell.nix │ └── reflex-platform.nix └── shell │ ├── haskell.nix │ └── reflex-platform.nix ├── patch.cabal ├── release.nix ├── shell.nix ├── src └── Data │ ├── Functor │ └── Misc.hs │ ├── Monoid │ └── DecidablyEmpty.hs │ ├── Patch.hs │ ├── Patch │ ├── Class.hs │ ├── DMap.hs │ ├── DMapWithMove.hs │ ├── IntMap.hs │ ├── Map.hs │ ├── MapWithMove.hs │ ├── MapWithPatchingMove.hs │ └── PatchOrReplacement.hs │ └── Semigroup │ └── Additive.hs ├── stylize └── test ├── hlint.hs └── tests.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :seti -XOverloadedStrings 3 | -------------------------------------------------------------------------------- /.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.1', '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 | # We don't run hlint tests, because different versions of hlint have different suggestions, and we don't want to worry about satisfying them all. 47 | run: cabal test --enable-tests -f-hlint all 48 | 49 | - if: matrix.ghc != '8.4.4' 50 | # docs aren't built on ghc 8.4.4 because some dependency docs don't build on older GHCs 51 | name: Build Docs 52 | run: cabal haddock 53 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal.sandbox.config 3 | cabal.project.local 4 | .cabal-sandbox/ 5 | dist-* 6 | cabal-dev 7 | *.o 8 | *.hi 9 | *.chi 10 | *.chs.h 11 | *.dyn_hi 12 | *.dyn_o 13 | *.p_hi 14 | *.p_o 15 | *.js_dyn_hi 16 | *.js_dyn_o 17 | *.js_p_hi 18 | *.js_p_o 19 | *.js_o 20 | *.js_hi 21 | .virthualenv 22 | .hsenv* 23 | *.*~ 24 | *.swp 25 | .DS_Store 26 | backend.pid 27 | backend.out 28 | .shelly 29 | TAGS 30 | tags 31 | *~ 32 | *.orig 33 | hsenv.log 34 | \#*# 35 | .#* 36 | /ghci-tmp 37 | *.dump-* 38 | *.verbose-core2core 39 | .nix 40 | -------------------------------------------------------------------------------- /.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 patch you were using. If you're using a github checkout, provide the git hash. 19 | * Describe how you're building patch (i.e., via reflex-platform, cabal install, stack, obelisk, etc.). If you're using reflex-platform or obelisk, provide the git hash of your checkout. 20 | 21 | ## Submitting Changes 22 | 23 | ### Guidelines for Commit Messages 24 | 25 | #### Summary Line 26 | The summary line of your commit message should summarize the changes being made. Commit messages should be written in the imperative mood and should describe what happens when the commit is applied. 27 | 28 | One way to think about it is that your commit message should be able to complete the sentence: 29 | "When applied, this commit will..." 30 | 31 | #### Body 32 | For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff. 33 | 34 | ### Guidelines for Pull Requests 35 | 36 | Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes. 37 | 38 | ### Code Quality 39 | 40 | #### Warnings 41 | 42 | Your pull request should add no new warnings to the project. It should also generally not disable any warnings. 43 | 44 | #### Build and Test 45 | 46 | Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner! 47 | 48 | #### Dependencies 49 | 50 | Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to patch.cabal also need to be added to default.nix. 51 | 52 | ### Documentation 53 | 54 | #### In the code 55 | We're always striving to improve documentation. Please include [haddock](https://haskell-haddock.readthedocs.io/en/latest/index.html) documentation for any added code, and update the documentation for any code you modify. 56 | 57 | #### In the [Changelog](ChangeLog.md) 58 | Add an entry to the changelog when your PR: 59 | * Adds a feature 60 | * Deprecates something 61 | * Includes a breaking change 62 | * Makes any other change that will impact users 63 | 64 | #### In the [Readme](README.md) 65 | The readme is the first place a lot of people look for information about the repository. Update any parts of the readme that are affected by your PR. 66 | 67 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for patch 2 | 3 | ## 0.0.8.4 4 | 5 | * Support for GHC 9.12 6 | 7 | ## 0.0.8.3 8 | 9 | * Add support for GHC 9.8 and 9.10 10 | 11 | * Replace partial `Map.lookup` with proper custom error for internal error. 12 | (This would make debugging a bug in the implementation easier.) 13 | 14 | ## 0.0.8.2 15 | 16 | * Add support for GHC 9.6 17 | 18 | ## 0.0.8.1 19 | 20 | * Add support for GHC 9.2 and 9.4 21 | 22 | ## 0.0.8.0 - 2022-12-09 23 | 24 | * Drop support for GHC 8.0 and 8.2. It may still be possible to use this library with those versions of GHC, but we do not guarantee or test it anymore. 25 | * Fix an issue where (<>) crashed for some `PatchMapWithPatchingMove`s. 26 | * Change `DecidablyEmpty` for `Sum` and `Product` to use `Num` and `Eq` rather than delegating to the argument type's `DecidablyEmpty` class. Since `Sum` and `Product` have `Monoid` actions and units that are inherently based on `Num`, it makes sense to have a `DecidablyEmpty` instances that inherently agree with that. Also, since `Int` and other numeric types don't have (and can't reasonably have) `DecidablyEmpty` instances, this is necessary to make them actually usable in this context. 27 | 28 | ## 0.0.7.0 - 2022-06-23 29 | 30 | * Use `commutative-semigroups` for `Commutative`, making `Additive` a 31 | deprecated alias. 32 | 33 | ## 0.0.6.0 - 2022-06-10 34 | 35 | * Add `PatchOrReplacement`, patch which either is some other patch type or a 36 | new replacement value. 37 | 38 | * Support GHC 9.2 39 | 40 | ## 0.0.5.2 - 2022-01-09 41 | 42 | * Correct field order of `PatchMapWithMove.NodeInfo`. 43 | 44 | When we this was reimplemented as a pattern synonym wrapper in 0.0.5.0, we 45 | accidentally flipped the argument order. Reversing it now to match 0.0.4.0 46 | and restore compatibility. The previous releases in the 0.0.5.\* series will 47 | correspondingly be deprecated. 48 | 49 | ## 0.0.5.1 - 2021-12-28 50 | 51 | * New dep of `base-orphans` for old GHC to get instances honestly instead of 52 | via `monoidal-containers`. 53 | 54 | ## 0.0.5.0 - 2021-12-17 55 | 56 | * `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported 57 | from `Data.Patch` for compatability. 58 | 59 | * Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`. 60 | Care is taken to make this not a breaking change. 61 | In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those. 62 | There are complete constructor and field patterns too, and everything is 63 | exported under the newtype as real constructors and fields would be. 64 | 65 | ## 0.0.4.0 - 2021-04-20 66 | 67 | * Enable PolyKinds 68 | 69 | ## 0.0.3.2 - 2020-11-06 70 | 71 | * Update version bounds 72 | 73 | ## 0.0.3.1 - 2020-02-05 74 | 75 | * Replace `fromJust` with something easier to debug. 76 | 77 | ## 0.0.3.0 - 2020-02-05 78 | 79 | * Create `PatchMapWithPatchingMove` variant which supports moves with a patch. 80 | 81 | * Create `DecidablyEmpty` subclass of `Monoid`. 82 | 83 | ## 0.0.2.0 - 2020-01-17 84 | 85 | * Consistently provide: 86 | 87 | - `Wrapped` instances 88 | 89 | - `*WithIndex` instances 90 | 91 | - `un*` newtype unwrappers 92 | 93 | for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`. 94 | 95 | ## 0.0.1.0 - 2020-01-09 96 | 97 | * Support older GHCs with `split-these` flag. 98 | 99 | * Additional instances for the `Group` class for basic types. 100 | 101 | ## 0.0.0.1 - 2020-01-08 102 | 103 | * Remove unneeded dependencies 104 | 105 | ## 0.0.0.0 - 2020-01-08 106 | 107 | * Extract patching functionality from Reflex. 108 | -------------------------------------------------------------------------------- /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 | # patch 2 | 3 | [![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/patch.svg)](https://hackage.haskell.org/package/patch) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/patch/LICENSE) 4 | 5 | Data structures for describing changes to other data structures. 6 | 7 | A `Patch` type represents a kind of change made to a data structure. 8 | 9 | ```haskell 10 | class Patch p where 11 | type PatchTarget p :: * 12 | -- | Apply the patch p a to the value a. If no change is needed, return 13 | -- 'Nothing'. 14 | apply :: p -> PatchTarget p -> Maybe (PatchTarget p) 15 | ``` 16 | 17 | ## Patching Maps 18 | For example, `Data.Patch.Map` defines the `PatchMap` type which can be used to patch `Map`s. A `PatchMap` represents updates to a `Map` that can insert, remove, or replace items in the `Map`. In this example, the `Map` is the `PatchTarget` and the `PatchMap` is the `Patch`. Keep in mind that there are many other possible `Patch`es that can be applied to a `Map` (i.e., `Map` can be the `PatchTarget` for many different `Patch` instances). 19 | 20 | `PatchMap` is defined as: 21 | 22 | ```haskell 23 | newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) } 24 | ``` 25 | 26 | The `Maybe` around the value is used to represent insertion/updates or deletion of the element at a given key. 27 | 28 | Its `Patch` instance begins with: 29 | 30 | ```haskell 31 | instance Ord k => Patch (PatchMap k v) where 32 | type PatchTarget (PatchMap k v) = Map k v 33 | ... 34 | ``` 35 | 36 | When a `PatchMap` is applied to its `PatchTarget`, the following changes can occur: 37 | 38 | - If the key is present in the `Patch` and the `PatchTarget`... 39 | 40 | - And the `Patch` value at that key is `Nothing`: delete that key from the `PatchTarget`. 41 | 42 | - And the `Patch` value at that key is `Just x`: update the value at that key in the `PatchTarget` to `x`. 43 | 44 | - If the key is present in the `Patch` and not present in the `PatchTarget`... 45 | 46 | - And the `Patch` value at that key is `Nothing`: do nothing because we're trying to delete a key that doesn't exist in the target in the first place. 47 | 48 | - And the `Patch` value at that key is `Just x`: insert the key and the value `x` into the `PatchTarget` 49 | 50 | - If the key is *not* present in the `Patch` but present in the `PatchTarget`: do nothing. 51 | 52 | There are, of course, more complicated ways of patching maps involving, for example, moving values from one key to another. You can find the code for that in `Data.Patch.PatchMapWithMove`. Note that the `PatchTarget` type associated with the `PatchMapWithMove` patch instance is still `Map k v`! 53 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | if arch(javascript) 4 | extra-packages: ghci 5 | -------------------------------------------------------------------------------- /nix/deps/nix-haskell-ci/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import (import ./thunk.nix) -------------------------------------------------------------------------------- /nix/deps/nix-haskell-ci/github.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "reflex-frp", 3 | "repo": "nix-haskell-ci", 4 | "branch": "main", 5 | "private": false, 6 | "rev": "17d1de24e89b9ca2c769d467b093d9c7fe58854e", 7 | "sha256": "01f0dm2rjyiz6dfx8sshdyipmp6vvzx671qnvv88sk6947l0v3cr" 8 | } 9 | -------------------------------------------------------------------------------- /nix/deps/nix-haskell-ci/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 -------------------------------------------------------------------------------- /nix/deps/nixpkgs/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import (import ./thunk.nix) -------------------------------------------------------------------------------- /nix/deps/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 | -------------------------------------------------------------------------------- /nix/deps/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 -------------------------------------------------------------------------------- /nix/deps/reflex-platform/default.nix: -------------------------------------------------------------------------------- 1 | # DO NOT HAND-EDIT THIS FILE 2 | import (import ./thunk.nix) -------------------------------------------------------------------------------- /nix/deps/reflex-platform/github.json: -------------------------------------------------------------------------------- 1 | { 2 | "owner": "reflex-frp", 3 | "repo": "reflex-platform", 4 | "branch": "develop", 5 | "private": false, 6 | "rev": "34c75631e7f2dd1409847b9df57252b96737e73a", 7 | "sha256": "1nwyybjy65b7qnb62wcm74nqfndr8prr2xsfvaianps0yzm366d0" 8 | } 9 | -------------------------------------------------------------------------------- /nix/deps/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 -------------------------------------------------------------------------------- /nix/project/haskell.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc910" }: 2 | 3 | { 4 | project = { 5 | src = ../../.; 6 | compiler-nix-name = compiler; 7 | }; 8 | } 9 | -------------------------------------------------------------------------------- /nix/release/haskell.nix: -------------------------------------------------------------------------------- 1 | { haskellNix ? null }: 2 | 3 | let ci = import ../deps/nix-haskell-ci (if haskellNix != null then { inherit haskellNix; } else {}); 4 | project = import ../project/haskell.nix {}; 5 | in with ci.haskell-nix; buildMatrix { inherit project; targets = matrix.default; } 6 | -------------------------------------------------------------------------------- /nix/release/reflex-platform.nix: -------------------------------------------------------------------------------- 1 | { reflex-platform-fun ? import ../deps/reflex-platform 2 | }: 3 | 4 | let native-reflex-platform = reflex-platform-fun { __useNewerCompiler = true; }; 5 | inherit (native-reflex-platform.nixpkgs) lib; 6 | systems = [ 7 | "x86_64-linux" 8 | # "x86_64-darwin" 9 | ]; 10 | 11 | perPlatform = lib.genAttrs systems (system: let 12 | srcFilter = 13 | builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ 14 | "release.nix" 15 | ".git" 16 | "dist" 17 | "dist-newstyle" 18 | "cabal.haskell-ci" 19 | "cabal.project" 20 | ".travis.yml" 21 | ])); 22 | reflex-platform = reflex-platform-fun { inherit system; __useNewerCompiler = true; }; 23 | compilers = [ 24 | "ghc" 25 | "ghcjs" 26 | ] ++ lib.optionals (reflex-platform.androidSupport) [ 27 | "ghcAndroidAarch64" 28 | "ghcAndroidAarch32" 29 | ] ++ lib.optionals (reflex-platform.iosSupport) [ 30 | "ghcIosAarch64" 31 | ]; 32 | nixpkgsGhcs = 33 | let 34 | pkgs = import ../deps/nixpkgs { inherit system; }; 35 | nixGhc945 = pkgs.haskell.packages.ghc945.override { 36 | }; 37 | nixGhc961 = pkgs.haskell.packages.ghc961.override { 38 | }; 39 | in 40 | { 41 | ghc945 = nixGhc945.callCabal2nix "patch" srcFilter {}; 42 | ghc961 = nixGhc961.callCabal2nix "patch" srcFilter {}; 43 | }; 44 | compilerPkgs = lib.genAttrs compilers (ghc: let 45 | reflex-platform = reflex-platform-fun { 46 | inherit system; 47 | __useNewerCompiler = true; 48 | haskellOverlays = [ 49 | # Use this package's source for reflex 50 | (self: super: { 51 | _dep = super._dep // { 52 | patch = srcFilter ../../.; 53 | }; 54 | }) 55 | ]; 56 | }; 57 | in reflex-platform.${ghc}.patch); 58 | in compilerPkgs // nixpkgsGhcs // { 59 | cache = reflex-platform.pinBuildInputs "patch-${system}" 60 | (builtins.attrValues compilerPkgs); 61 | }); 62 | 63 | metaCache = native-reflex-platform.pinBuildInputs "patch-everywhere" 64 | (map (a: a.cache) (builtins.attrValues perPlatform)); 65 | 66 | in perPlatform // { inherit metaCache; } 67 | -------------------------------------------------------------------------------- /nix/shell/haskell.nix: -------------------------------------------------------------------------------- 1 | { haskellNix ? null }: 2 | 3 | let ci = import ../deps/nix-haskell-ci (if haskellNix != null then { inherit haskellNix; } else {}); 4 | haskell = ci.nix-haskell; 5 | project = import ../project/haskell.nix {}; 6 | in haskell.project project 7 | -------------------------------------------------------------------------------- /nix/shell/reflex-platform.nix: -------------------------------------------------------------------------------- 1 | let 2 | rp = import ../deps/reflex-platform { __useNewerCompiler = true; }; 3 | pkgs = rp.nixpkgs; 4 | system = builtins.currentSystem; 5 | in 6 | pkgs.mkShell { 7 | name = "shell"; 8 | buildInputs = [ 9 | pkgs.cabal-install 10 | pkgs.ghcid 11 | ]; 12 | inputsFrom = [ 13 | (import ../release/reflex-platform.nix {}).${system}.ghc.env 14 | ]; 15 | } 16 | -------------------------------------------------------------------------------- /patch.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: patch 3 | version: 0.0.8.4 4 | license: BSD3 5 | license-file: LICENSE 6 | maintainer: maintainer@obsidian.systems 7 | author: Ryan Trinkle 8 | stability: Experimental 9 | tested-with: 10 | ghc ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.5 || ==9.4.5 || ==9.6.1 || ==9.8.2 || ==9.10.1 || ==9.12.1 11 | ghcjs ==8.6 || ==8.10 12 | 13 | homepage: https://obsidian.systems 14 | bug-reports: https://github.com/reflex-frp/patch/issues 15 | synopsis: 16 | Data structures for describing changes to other data structures. 17 | 18 | description: 19 | Data structures for describing changes to other data structures. 20 | . 21 | In this library, a patch is something which can be applied, analogous to a 22 | function, and which distinguishes returning the argument it was provided from 23 | returning something else. 24 | 25 | category: FRP 26 | build-type: Simple 27 | extra-source-files: 28 | README.md 29 | ChangeLog.md 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/reflex-frp/patch 34 | 35 | flag split-these 36 | description: Use split these/semialign packages 37 | 38 | flag hlint 39 | description: Enable hlint test 40 | 41 | library 42 | exposed-modules: 43 | Data.Functor.Misc 44 | Data.Monoid.DecidablyEmpty 45 | Data.Patch 46 | Data.Patch.Class 47 | Data.Patch.DMap 48 | Data.Patch.DMapWithMove 49 | Data.Patch.IntMap 50 | Data.Patch.Map 51 | Data.Patch.MapWithMove 52 | Data.Patch.MapWithPatchingMove 53 | Data.Patch.PatchOrReplacement 54 | Data.Semigroup.Additive 55 | 56 | hs-source-dirs: src 57 | default-language: Haskell2010 58 | default-extensions: PolyKinds 59 | ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs 60 | build-depends: 61 | base >=4.9 && <=4.22, 62 | constraints-extras >=0.3 && <0.5, 63 | commutative-semigroups >=0.0 && <0.3, 64 | containers >=0.6 && <0.8, 65 | dependent-map >=0.3 && <0.5, 66 | dependent-sum >=0.6 && <0.8, 67 | lens >=4.7 && <5.4, 68 | indexed-traversable >=0.1 && <0.2, 69 | semigroupoids >=4.0 && <7, 70 | transformers >=0.5.6.0 && <0.7, 71 | witherable >=0.3 && <0.6 72 | 73 | if impl(ghc <8.6) 74 | build-depends: base-orphans >=0.8 && <0.10 75 | 76 | if flag(split-these) 77 | build-depends: 78 | these >=1 && <1.3, 79 | semialign >=1 && <1.4, 80 | monoidal-containers >=0.6 && <0.7 81 | 82 | else 83 | build-depends: 84 | these >=0.4 && <0.9, 85 | monoidal-containers ==0.4.0.0 86 | 87 | test-suite tests 88 | type: exitcode-stdio-1.0 89 | main-is: tests.hs 90 | hs-source-dirs: test 91 | default-language: Haskell2010 92 | build-depends: 93 | base, 94 | patch, 95 | containers, 96 | hedgehog <1.6, 97 | HUnit <1.7 98 | 99 | if (impl(ghcjs >=0) || arch(javascript)) 100 | buildable: False 101 | 102 | test-suite hlint 103 | type: exitcode-stdio-1.0 104 | main-is: hlint.hs 105 | hs-source-dirs: test 106 | default-language: Haskell2010 107 | build-depends: 108 | base, 109 | directory, 110 | filepath, 111 | filemanip, 112 | patch 113 | 114 | if impl(ghc >=9.6) 115 | buildable: False 116 | 117 | if impl(ghc <9.2) 118 | build-depends: hlint (<2.1 || >=2.2.2) && <3.5 119 | 120 | else 121 | build-depends: hlint >=3.5 && <3.6 122 | 123 | if ((impl(ghcjs >=0) || arch(javascript)) || !flag(hlint)) 124 | buildable: False 125 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | 3 | let reflex-platform-release = import ./nix/release/reflex-platform.nix {}; 4 | haskell-nix-release = import ./nix/release/haskell.nix {}; 5 | 6 | in pkgs.runCommand "release" {} '' 7 | mkdir -p $out 8 | 9 | ln -s ${reflex-platform-release.metaCache} $out/reflex-platform 10 | ln -s ${haskell-nix-release} $out/haskell-nix 11 | '' 12 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | 3 | let reflex-platform-shell = import ./nix/shell/reflex-platform.nix; 4 | haskell-nix-shell = import ./nix/shell/haskell.nix {}; 5 | 6 | in { 7 | inherit reflex-platform-shell; 8 | inherit haskell-nix-shell; 9 | } 10 | -------------------------------------------------------------------------------- /src/Data/Functor/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | 14 | {- | 15 | Description: Misc utilities relating to functor. 16 | 17 | This module provides types and functions with no particular theme, but which 18 | are relevant to the use of 'Functor'-based datastructures like 19 | 'Data.Dependent.Map.DMap'. 20 | -} 21 | module Data.Functor.Misc 22 | ( -- * Const2 23 | Const2 (..) 24 | , unConst2 25 | , dmapToMap 26 | , dmapToIntMap 27 | , dmapToMapWith 28 | , mapToDMap 29 | , weakenDMapWith 30 | -- * WrapArg 31 | , WrapArg (..) 32 | -- * Convenience functions for DMap 33 | , mapWithFunctorToDMap 34 | , intMapWithFunctorToDMap 35 | , mapKeyValuePairsMonotonic 36 | , combineDMapsWithKey 37 | , EitherTag (..) 38 | , dmapToThese 39 | , eitherToDSum 40 | , dsumToEither 41 | , ComposeMaybe (..) 42 | ) where 43 | 44 | import Data.Dependent.Map (DMap) 45 | import qualified Data.Dependent.Map as DMap 46 | import Data.Dependent.Sum 47 | import Data.Functor.Identity 48 | import Data.GADT.Compare 49 | import Data.GADT.Show 50 | import Data.IntMap (IntMap) 51 | import qualified Data.IntMap as IntMap 52 | import Data.Kind (Type) 53 | import Data.Map (Map) 54 | import qualified Data.Map as Map 55 | import Data.Some (Some, mkSome) 56 | import Data.These 57 | import Data.Type.Equality ((:~:)(Refl)) 58 | 59 | -------------------------------------------------------------------------------- 60 | -- Const2 61 | -------------------------------------------------------------------------------- 62 | 63 | -- | @'Const2' k v v@ stores a value of a given type @k@ and ensures 64 | -- that a particular type @v@ is always given for the last type 65 | -- parameter 66 | data Const2 :: Type -> x -> x -> Type where 67 | Const2 :: k -> Const2 k v v 68 | 69 | -- | Extract the value from a Const2 70 | unConst2 :: Const2 k v v' -> k 71 | unConst2 (Const2 k) = k 72 | 73 | deriving instance Eq k => Eq (Const2 k v v') 74 | deriving instance Ord k => Ord (Const2 k v v') 75 | deriving instance Show k => Show (Const2 k v v') 76 | deriving instance Read k => Read (Const2 k v v) 77 | 78 | instance Show k => GShow (Const2 k v) where 79 | gshowsPrec n x@(Const2 _) = showsPrec n x 80 | 81 | instance Eq k => GEq (Const2 k v) where 82 | geq (Const2 a) (Const2 b) = 83 | if a == b 84 | then Just Refl 85 | else Nothing 86 | 87 | instance Ord k => GCompare (Const2 k v) where 88 | gcompare (Const2 a) (Const2 b) = case compare a b of 89 | LT -> GLT 90 | EQ -> GEQ 91 | GT -> GGT 92 | 93 | -- | Convert a 'DMap' to a regular 'Map' 94 | dmapToMap :: DMap (Const2 k v) Identity -> Map k v 95 | dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList 96 | 97 | -- | Convert a 'DMap' to an 'IntMap' 98 | dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v 99 | dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList 100 | 101 | -- | Convert a 'DMap' to a regular 'Map', applying the given function to remove 102 | -- the wrapping 'Functor' 103 | dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v' 104 | dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList 105 | 106 | -- | Convert a regular 'Map' to a 'DMap' 107 | mapToDMap :: Map k v -> DMap (Const2 k v) Identity 108 | mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList 109 | 110 | -- | Convert a regular 'Map', where the values are already wrapped in a functor, 111 | -- to a 'DMap' 112 | mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f 113 | mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList 114 | 115 | -- | Convert a regular 'IntMap', where the values are already wrapped in a 116 | -- functor, to a 'DMap' 117 | intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f 118 | intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList 119 | 120 | -- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with 121 | -- the keys, using a function to remove the wrapping 'Functor' 122 | weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v' 123 | weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (mkSome k, f v)) . DMap.toAscList 124 | 125 | -------------------------------------------------------------------------------- 126 | -- WrapArg 127 | -------------------------------------------------------------------------------- 128 | 129 | -- | 'WrapArg' can be used to tag a value in one functor with a type 130 | -- representing another functor. This was primarily used with dependent-map < 131 | -- 0.2, in which the value type was not wrapped in a separate functor. 132 | data WrapArg :: (k -> Type) -> (k -> Type) -> Type -> Type where 133 | WrapArg :: f a -> WrapArg g f (g a) 134 | 135 | deriving instance Eq (f a) => Eq (WrapArg g f (g' a)) 136 | deriving instance Ord (f a) => Ord (WrapArg g f (g' a)) 137 | deriving instance Show (f a) => Show (WrapArg g f (g' a)) 138 | deriving instance Read (f a) => Read (WrapArg g f (g a)) 139 | 140 | instance GEq f => GEq (WrapArg g f) where 141 | geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b 142 | 143 | instance GCompare f => GCompare (WrapArg g f) where 144 | gcompare (WrapArg a) (WrapArg b) = case gcompare a b of 145 | GLT -> GLT 146 | GEQ -> GEQ 147 | GGT -> GGT 148 | 149 | -------------------------------------------------------------------------------- 150 | -- Convenience functions for DMap 151 | -------------------------------------------------------------------------------- 152 | 153 | -- | Map over all key/value pairs in a 'DMap', potentially altering the key as 154 | -- well as the value. The provided function MUST preserve the ordering of the 155 | -- keys, or the resulting 'DMap' will be malformed. 156 | mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v' 157 | mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList 158 | 159 | {-# INLINE combineDMapsWithKey #-} 160 | -- | Union two 'DMap's of different types, yielding another type. Each key that 161 | -- is present in either input map will be present in the output. 162 | combineDMapsWithKey :: forall f g h i. 163 | GCompare f 164 | => (forall a. f a -> These (g a) (h a) -> i a) 165 | -> DMap f g 166 | -> DMap f h 167 | -> DMap f i 168 | combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh) 169 | where go :: [DSum f g] -> [DSum f h] -> [DSum f i] 170 | go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs 171 | go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs 172 | go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of 173 | GLT -> (gk :=> f gk (This gv)) : go gs' hs 174 | GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs' 175 | GGT -> (hk :=> f hk (That hv)) : go gs hs' 176 | 177 | -- | Extract the values of a 'DMap' of 'EitherTag's. 178 | dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b) 179 | dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of 180 | (Nothing, Nothing) -> Nothing 181 | (Just (Identity a), Nothing) -> Just $ This a 182 | (Nothing, Just (Identity b)) -> Just $ That b 183 | (Just (Identity a), Just (Identity b)) -> Just $ These a b 184 | 185 | -- | Tag type for 'Either' to use it as a 'DSum'. 186 | data EitherTag l r a where 187 | LeftTag :: EitherTag l r l 188 | RightTag :: EitherTag l r r 189 | 190 | deriving instance Show (EitherTag l r a) 191 | deriving instance Eq (EitherTag l r a) 192 | deriving instance Ord (EitherTag l r a) 193 | 194 | instance GEq (EitherTag l r) where 195 | geq a b = case (a, b) of 196 | (LeftTag, LeftTag) -> Just Refl 197 | (RightTag, RightTag) -> Just Refl 198 | _ -> Nothing 199 | 200 | instance GCompare (EitherTag l r) where 201 | gcompare a b = case (a, b) of 202 | (LeftTag, LeftTag) -> GEQ 203 | (LeftTag, RightTag) -> GLT 204 | (RightTag, LeftTag) -> GGT 205 | (RightTag, RightTag) -> GEQ 206 | 207 | instance GShow (EitherTag l r) where 208 | gshowsPrec _ a = case a of 209 | LeftTag -> showString "LeftTag" 210 | RightTag -> showString "RightTag" 211 | 212 | -- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'. 213 | eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity 214 | eitherToDSum = \case 215 | Left a -> (LeftTag :=> Identity a) 216 | Right b -> (RightTag :=> Identity b) 217 | 218 | -- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'. 219 | dsumToEither :: DSum (EitherTag a b) Identity -> Either a b 220 | dsumToEither = \case 221 | (LeftTag :=> Identity a) -> Left a 222 | (RightTag :=> Identity b) -> Right b 223 | 224 | -------------------------------------------------------------------------------- 225 | -- ComposeMaybe 226 | -------------------------------------------------------------------------------- 227 | 228 | -- | We can't use @'Data.Functor.Compose.Compose' 'Maybe'@ instead of @'ComposeMaybe'@, 229 | -- because that would make the @f@ parameter have a nominal type role. 230 | -- We need @f@ to be representational so that we can use safe 231 | -- @'Data.Coerce.coerce'@. 232 | newtype ComposeMaybe f a = 233 | ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord) 234 | 235 | deriving instance Functor f => Functor (ComposeMaybe f) 236 | -------------------------------------------------------------------------------- /src/Data/Monoid/DecidablyEmpty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | -- TODO upstream somwhere else? 8 | {-| 9 | Description: This module provides a class to decide whether a monoid element is the identity. 10 | -} 11 | module Data.Monoid.DecidablyEmpty where 12 | 13 | import Data.Functor.Identity 14 | import Data.Functor.Const 15 | import Data.Monoid 16 | import Data.Maybe (isNothing) 17 | #if MIN_VERSION_base(4,11,0) 18 | import Data.Ord 19 | #endif 20 | import Data.Proxy 21 | import Data.Semigroup hiding (First, Last) 22 | #if MIN_VERSION_base(4,12,0) 23 | import GHC.Generics 24 | #endif 25 | 26 | import qualified Data.IntSet as IntSet 27 | import qualified Data.IntMap as IntMap 28 | import qualified Data.Map as Map 29 | import qualified Data.Sequence as Seq 30 | import qualified Data.Set as Set 31 | 32 | import Data.GADT.Compare 33 | import qualified Data.Dependent.Map as DMap 34 | 35 | -- | A 'DecidablyEmpty' is one where it can be computed whether or not an 36 | -- arbitrary value is 'mempty'. 37 | -- 38 | -- By using this class rather than 'Eq', we avoid unnecessary constraining the 39 | -- contents of 'Functor's. This makes it possible to efficiently combine and/or 40 | -- nest patch maps with 'Eq'-lacking values (e.g. functions) at the leaves. 41 | class Monoid a => DecidablyEmpty a where 42 | isEmpty :: a -> Bool 43 | default isEmpty :: Eq a => a -> Bool 44 | isEmpty = (==) mempty 45 | 46 | -- base 47 | 48 | instance DecidablyEmpty Ordering 49 | instance DecidablyEmpty () 50 | instance DecidablyEmpty Any 51 | instance DecidablyEmpty All 52 | -- instance DecidablyEmpty Lifetime 53 | -- instance DecidablyEmpty Event 54 | instance DecidablyEmpty [a] where 55 | isEmpty = null 56 | instance 57 | #if MIN_VERSION_base(4,11,0) 58 | Semigroup a 59 | #else 60 | Monoid a 61 | #endif 62 | => DecidablyEmpty (Maybe a) where 63 | isEmpty = isNothing 64 | instance (Num a, Eq a) => DecidablyEmpty (Product a) where 65 | isEmpty = (== 1) 66 | instance (Num a, Eq a) => DecidablyEmpty (Sum a) where 67 | isEmpty = (== 0) 68 | deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a) 69 | instance DecidablyEmpty (First a) where 70 | isEmpty (First a) = isNothing a 71 | instance DecidablyEmpty (Last a) where 72 | isEmpty (Last a) = isNothing a 73 | deriving instance DecidablyEmpty a => DecidablyEmpty (Identity a) 74 | #if !MIN_VERSION_base(4,16,0) 75 | instance Semigroup a => DecidablyEmpty (Option a) where 76 | isEmpty (Option a) = isNothing a 77 | #endif 78 | deriving instance DecidablyEmpty m => DecidablyEmpty (WrappedMonoid m) 79 | instance (Ord a, Bounded a) => DecidablyEmpty (Max a) 80 | instance (Ord a, Bounded a) => DecidablyEmpty (Min a) 81 | instance DecidablyEmpty (Proxy s) 82 | deriving instance DecidablyEmpty a => DecidablyEmpty (Const a b) 83 | #if MIN_VERSION_base(4,11,0) 84 | deriving instance DecidablyEmpty a => DecidablyEmpty (Down a) 85 | #endif 86 | #if MIN_VERSION_base(4,12,0) 87 | deriving instance DecidablyEmpty p => DecidablyEmpty (Par1 p) 88 | instance DecidablyEmpty (U1 p) 89 | deriving instance DecidablyEmpty (f p) => DecidablyEmpty (Rec1 f p) 90 | deriving instance DecidablyEmpty (f p) => DecidablyEmpty (M1 i c f p) 91 | deriving instance DecidablyEmpty c => DecidablyEmpty (K1 i c p) 92 | instance (DecidablyEmpty (f p), DecidablyEmpty (g p)) => DecidablyEmpty ((f :*: g) p) where 93 | isEmpty (x :*: y) = isEmpty x && isEmpty y 94 | deriving instance DecidablyEmpty (f (g p)) => DecidablyEmpty ((f :.: g) p) 95 | #endif 96 | 97 | instance (DecidablyEmpty a, DecidablyEmpty b) => DecidablyEmpty (a, b) where 98 | isEmpty (a, b) = isEmpty a && isEmpty b 99 | instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c) => DecidablyEmpty (a, b, c) where 100 | isEmpty (a, b, c) = isEmpty a && isEmpty b && isEmpty c 101 | instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d) => DecidablyEmpty (a, b, c, d) where 102 | isEmpty (a, b, c, d) = isEmpty a && isEmpty b && isEmpty c && isEmpty d 103 | instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d, DecidablyEmpty e) => DecidablyEmpty (a, b, c, d, e) where 104 | isEmpty (a, b, c, d, e) = isEmpty a && isEmpty b && isEmpty c && isEmpty d && isEmpty e 105 | 106 | -- containers 107 | 108 | instance DecidablyEmpty IntSet.IntSet where 109 | isEmpty = IntSet.null 110 | instance DecidablyEmpty (IntMap.IntMap v) where 111 | isEmpty = IntMap.null 112 | instance Ord k => DecidablyEmpty (Map.Map k v) where 113 | isEmpty = Map.null 114 | instance DecidablyEmpty (Seq.Seq v) where 115 | isEmpty = Seq.null 116 | instance Ord k => DecidablyEmpty (Set.Set k) where 117 | isEmpty = Set.null 118 | 119 | -- dependent-map 120 | 121 | instance GCompare k => DecidablyEmpty (DMap.DMap k v) where 122 | isEmpty = DMap.null 123 | -------------------------------------------------------------------------------- /src/Data/Patch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | {-| 8 | Description: 9 | This module defines the 'Group' class, and reexports the other modules. 10 | -} 11 | module Data.Patch 12 | ( module Data.Patch 13 | , module X 14 | ) where 15 | 16 | import Data.Semigroup.Commutative 17 | import Data.Functor.Const (Const (..)) 18 | import Data.Functor.Identity 19 | import Data.Map.Monoidal (MonoidalMap) 20 | import Data.Proxy 21 | import GHC.Generics 22 | 23 | #if !MIN_VERSION_base(4,18,0) 24 | import Control.Applicative (liftA2) 25 | #endif 26 | 27 | #if !MIN_VERSION_base(4,11,0) 28 | import Data.Semigroup (Semigroup (..)) 29 | #endif 30 | 31 | -- N.B. Intentionally reexporting `Additive`, the deprecated alias, as 32 | -- this is a reexport for backwards compatibility. 33 | import Data.Semigroup.Additive as X 34 | import Data.Patch.Class as X 35 | import Data.Patch.DMap as X hiding (getDeletions) 36 | import Data.Patch.DMapWithMove as X 37 | ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove 38 | , patchDMapWithMoveToPatchMapWithMoveWith 39 | , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove 40 | , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith 41 | ) 42 | import Data.Patch.IntMap as X hiding (getDeletions) 43 | import Data.Patch.Map as X 44 | import Data.Patch.MapWithMove as X 45 | ( PatchMapWithMove, patchMapWithMoveNewElements 46 | , patchMapWithMoveNewElementsMap, unPatchMapWithMove 47 | , unsafePatchMapWithMove 48 | ) 49 | 50 | -- | A 'Group' is a 'Monoid' where every element has an inverse. 51 | class (Semigroup q, Monoid q) => Group q where 52 | negateG :: q -> q 53 | (~~) :: q -> q -> q 54 | r ~~ s = r <> negateG s 55 | 56 | -- | The elements of an 'Commutative' 'Semigroup' can be considered as patches of their own type. 57 | newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p } 58 | 59 | instance Commutative p => Patch (AdditivePatch p) where 60 | type PatchTarget (AdditivePatch p) = p 61 | apply (AdditivePatch p) q = Just $ p <> q 62 | 63 | instance (Ord k, Group q) => Group (MonoidalMap k q) where 64 | negateG = fmap negateG 65 | 66 | -- | Trivial group. 67 | instance Group () where 68 | negateG _ = () 69 | _ ~~ _ = () 70 | 71 | -- | Product group. A Pair of groups gives rise to a group 72 | instance (Group a, Group b) => Group (a, b) where 73 | negateG (a, b) = (negateG a, negateG b) 74 | (a, b) ~~ (c, d) = (a ~~ c, b ~~ d) 75 | 76 | -- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided. 77 | -- Base does not define Monoid (Compose f g a) so this is the best we can 78 | -- really do for functor composition. 79 | instance Group (f (g a)) => Group ((f :.: g) a) where 80 | negateG (Comp1 xs) = Comp1 (negateG xs) 81 | Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys) 82 | 83 | -- | Product of groups, Functor style. 84 | instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where 85 | negateG (a :*: b) = negateG a :*: negateG b 86 | (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d) 87 | 88 | -- | Trivial group, Functor style 89 | instance Group (Proxy x) where 90 | negateG _ = Proxy 91 | _ ~~ _ = Proxy 92 | 93 | -- | Const lifts groups into a functor. 94 | deriving instance Group a => Group (Const a x) 95 | 96 | -- | Identity lifts groups pointwise (at only one point) 97 | deriving instance Group a => Group (Identity a) 98 | 99 | -- | Functions lift groups pointwise. 100 | instance Group b => Group (a -> b) where 101 | negateG f = negateG . f 102 | (~~) = liftA2 (~~) 103 | -------------------------------------------------------------------------------- /src/Data/Patch/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | {-| 6 | Description: The module provides the 'Patch' class. 7 | 8 | This is a class for types which represent changes made to other types 9 | -} 10 | module Data.Patch.Class where 11 | 12 | import Data.Functor.Identity 13 | import Data.Kind (Type) 14 | import Data.Maybe 15 | import Data.Semigroup 16 | ( Sum (..) 17 | , Product (..) 18 | #if !MIN_VERSION_base(4,11,0) 19 | , Semigroup(..) 20 | #endif 21 | ) 22 | import Data.Proxy 23 | 24 | -- | A 'Patch' type represents a kind of change made to a datastructure. 25 | -- 26 | -- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey 27 | -- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@. 28 | class Patch p where 29 | type PatchTarget p :: Type 30 | -- | Apply the patch @p a@ to the value @a@. If no change is needed, return 31 | -- 'Nothing'. 32 | apply :: p -> PatchTarget p -> Maybe (PatchTarget p) 33 | 34 | -- | Apply a 'Patch'; if it does nothing, return the original value 35 | applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p 36 | applyAlways p t = fromMaybe t $ apply p t 37 | 38 | -- | 'Identity' can be used as a 'Patch' that always fully replaces the value 39 | instance Patch (Identity a) where 40 | type PatchTarget (Identity a) = a 41 | apply (Identity a) _ = Just a 42 | 43 | -- | 'Proxy' can be used as a 'Patch' that does nothing. 44 | instance forall (a :: Type). Patch (Proxy a) where 45 | type PatchTarget (Proxy a) = a 46 | apply ~Proxy _ = Nothing 47 | 48 | instance (Num a, Eq a) => Patch (Sum a) where 49 | type PatchTarget (Sum a) = a 50 | apply (Sum a) b = if a == 0 then Nothing else Just $ a + b 51 | 52 | instance (Num a, Eq a) => Patch (Product a) where 53 | type PatchTarget (Product a) = a 54 | apply (Product a) b = if a == 1 then Nothing else Just $ a * b 55 | 56 | -- | Like '(.)', but composes functions that return patches rather than 57 | -- functions that return new values. The Semigroup instance for patches must 58 | -- apply patches right-to-left, like '(.)'. 59 | composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p 60 | composePatchFunctions g f a = 61 | let fp = f a 62 | in g (applyAlways fp a) <> fp 63 | -------------------------------------------------------------------------------- /src/Data/Patch/DMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Description: A basic 'Patch' on 'DMap' 12 | 13 | Patches of this type consist only of insertions (including overwrites) and 14 | deletions. 15 | -} 16 | module Data.Patch.DMap where 17 | 18 | import Data.Patch.Class 19 | import Data.Patch.IntMap 20 | import Data.Patch.Map 21 | 22 | import Data.Dependent.Map (DMap) 23 | import Data.Dependent.Sum (DSum (..)) 24 | import Data.GADT.Compare (GCompare (..)) 25 | import qualified Data.Dependent.Map as DMap 26 | import Data.Functor.Constant 27 | import Data.Functor.Misc 28 | import qualified Data.IntMap as IntMap 29 | import qualified Data.Map as Map 30 | import Data.Monoid.DecidablyEmpty 31 | #if !MIN_VERSION_base(4,11,0) 32 | import Data.Semigroup (Semigroup (..)) 33 | #endif 34 | import Data.Some (Some) 35 | 36 | -- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted. 37 | -- Insertions are represented as @'ComposeMaybe' (Just value)@, 38 | -- while deletions are represented as @'ComposeMaybe' Nothing@. 39 | newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) } 40 | 41 | deriving instance GCompare k => Semigroup (PatchDMap k v) 42 | 43 | deriving instance GCompare k => Monoid (PatchDMap k v) 44 | 45 | -- It won't let me derive for some reason 46 | instance GCompare k => DecidablyEmpty (PatchDMap k v) where 47 | isEmpty (PatchDMap m) = DMap.null m 48 | 49 | -- | Apply the insertions or deletions to a given 'DMap'. 50 | instance GCompare k => Patch (PatchDMap k v) where 51 | type PatchTarget (PatchDMap k v) = DMap k v 52 | apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? 53 | where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff 54 | deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff 55 | nothingToJust = \case 56 | Nothing -> Just $ Constant () 57 | Just _ -> Nothing 58 | 59 | -- | Map a function @v a -> v' a@ over any inserts/updates in the given 60 | -- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. 61 | mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v' 62 | mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p 63 | 64 | -- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given 65 | -- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. 66 | traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v') 67 | traversePatchDMap f = traversePatchDMapWithKey $ const f 68 | 69 | -- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates 70 | -- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. 71 | traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v') 72 | traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p 73 | 74 | -- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function 75 | -- @v a -> v'@ to weaken each value contained in the patch. 76 | weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v' 77 | weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p 78 | 79 | -- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of 80 | -- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@. 81 | patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v' 82 | patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p 83 | 84 | -- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@. 85 | const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v' 86 | const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p 87 | where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v') 88 | g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) 89 | 90 | -- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@. 91 | const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f 92 | const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p 93 | where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f) 94 | g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) 95 | 96 | -- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'. 97 | getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v' 98 | getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p 99 | -------------------------------------------------------------------------------- /src/Data/Patch/DMapWithMove.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PatternGuards #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE Rank2Types #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | {-| 15 | Description: A more advanced 'Patch' for 'DMap'. 16 | 17 | This Module contains @'PatchDMapWithMove' k v@ and associated functions, which 18 | represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and 19 | move values between keys. 20 | -} 21 | module Data.Patch.DMapWithMove where 22 | 23 | import Data.Patch.Class 24 | import Data.Patch.MapWithMove (PatchMapWithMove (..)) 25 | import qualified Data.Patch.MapWithMove as MapWithMove 26 | 27 | import Data.Constraint.Extras 28 | import Data.Dependent.Map (DMap) 29 | import Data.Dependent.Sum (DSum (..)) 30 | import qualified Data.Dependent.Map as DMap 31 | import Data.Functor.Constant 32 | import Data.Functor.Misc 33 | import Data.Functor.Product 34 | import Data.GADT.Compare (GEq (..), GCompare (..)) 35 | import Data.GADT.Show (GShow, gshow) 36 | import Data.Kind (Type) 37 | import qualified Data.Map as Map 38 | import Data.Maybe 39 | import Data.Monoid.DecidablyEmpty 40 | #if !MIN_VERSION_base(4,11,0) 41 | import Data.Semigroup (Semigroup (..)) 42 | #endif 43 | import Data.Some (Some, mkSome) 44 | import Data.These 45 | 46 | -- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and 47 | -- destinations. 48 | -- 49 | -- Invariants: 50 | -- 51 | -- * A key should not move to itself. 52 | -- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@) 53 | newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v)) 54 | 55 | -- It won't let me derive for some reason 56 | instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where 57 | isEmpty (PatchDMapWithMove m) = DMap.null m 58 | 59 | -- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key 60 | -- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move. 61 | data NodeInfo k v a = NodeInfo 62 | { _nodeInfo_from :: !(From k v a) 63 | -- ^Change applying to the current key, be it an insert, move, or delete. 64 | , _nodeInfo_to :: !(To k a) 65 | -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'. 66 | } 67 | deriving (Show) 68 | 69 | -- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a 70 | -- key (@From_Delete@), or moving a key (@From_Move@). 71 | data From (k :: a -> Type) (v :: a -> Type) :: a -> Type where 72 | -- |Insert a new or update an existing key with the given value @v a@ 73 | From_Insert :: v a -> From k v a 74 | -- |Delete the existing key 75 | From_Delete :: From k v a 76 | -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@, 77 | -- usually but not necessarily with @From_Delete@. 78 | From_Move :: !(k a) -> From k v a 79 | deriving (Show, Read, Eq, Ord) 80 | 81 | -- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other 82 | -- operation. 83 | type To = ComposeMaybe 84 | 85 | -- |Test whether a 'PatchDMapWithMove' satisfies its invariants. 86 | validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool 87 | validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove 88 | 89 | -- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid. 90 | validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String] 91 | validationErrorsForPatchDMapWithMove m = 92 | noSelfMoves <> movesBalanced 93 | where 94 | noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m 95 | selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side" 96 | selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side" 97 | selfMove _ = Nothing 98 | movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m 99 | unbalancedMove (dst :=> NodeInfo (From_Move src) _) = 100 | case DMap.lookup src m of 101 | Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch" 102 | Just (NodeInfo _ (ComposeMaybe (Just dst'))) -> 103 | if isNothing (dst' `geq` dst) 104 | then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead" 105 | else Nothing 106 | _ -> 107 | Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key" 108 | unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) = 109 | case DMap.lookup dst m of 110 | Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch" 111 | Just (NodeInfo (From_Move src') _) -> 112 | if isNothing (src' `geq` src) 113 | then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead" 114 | else Nothing 115 | 116 | _ -> 117 | Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving" 118 | unbalancedMove _ = Nothing 119 | 120 | -- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations. 121 | instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where 122 | PatchDMapWithMove a == PatchDMapWithMove b = a == b 123 | 124 | -- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9 125 | data Pair1 f g a = Pair1 (f a) (g a) 126 | 127 | -- |Helper data structure used for composing patches using the monoid instance. 128 | data Fixup k v a 129 | = Fixup_Delete 130 | | Fixup_Update (These (From k v a) (To k a)) 131 | 132 | -- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ 133 | instance GCompare k => Semigroup (PatchDMapWithMove k v) where 134 | PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m 135 | where 136 | connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb 137 | h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)] 138 | h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of 139 | (Just toAfter, From_Move fromBefore) 140 | | isJust $ fromBefore `geq` toAfter 141 | -> [toAfter :=> Fixup_Delete] 142 | | otherwise 143 | -> [ toAfter :=> Fixup_Update (This editBefore) 144 | , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter)) 145 | ] 146 | (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map 147 | (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)] 148 | (Nothing, _) -> [] 149 | mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete 150 | mergeFixups _ (Fixup_Update a) (Fixup_Update b) 151 | | This x <- a, That y <- b 152 | = Fixup_Update $ These x y 153 | | That y <- a, This x <- b 154 | = Fixup_Update $ These x y 155 | mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups" 156 | fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections 157 | combineNodeInfos _ nia nib = NodeInfo 158 | { _nodeInfo_from = _nodeInfo_from nia 159 | , _nodeInfo_to = _nodeInfo_to nib 160 | } 161 | applyFixup _ ni = \case 162 | Fixup_Delete -> Nothing 163 | Fixup_Update u -> Just $ NodeInfo 164 | { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u 165 | , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u 166 | } 167 | m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups 168 | getHere :: These a b -> Maybe a 169 | getHere = \case 170 | This a -> Just a 171 | These a _ -> Just a 172 | That _ -> Nothing 173 | getThere :: These a b -> Maybe b 174 | getThere = \case 175 | This _ -> Nothing 176 | These _ b -> Just b 177 | That b -> Just b 178 | 179 | -- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ 180 | instance GCompare k => Monoid (PatchDMapWithMove k v) where 181 | mempty = PatchDMapWithMove mempty 182 | mappend = (<>) 183 | 184 | {- 185 | mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v 186 | PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src 187 | where 188 | getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself 189 | removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing 190 | removeRedundantDst _ a = Just a 191 | f :: forall a. k a -> From k v a -> Maybe (From k v a) 192 | f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of 193 | From_Move fromKey -> getDstAction fromKey dstBefore 194 | nonMove -> nonMove 195 | dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore 196 | getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m 197 | removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing 198 | removeRedundantSrc _ a = Just a 199 | g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a) 200 | g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of 201 | ComposeMaybe Nothing -> ComposeMaybe Nothing 202 | ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter 203 | src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore 204 | -} 205 | 206 | -- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'. 207 | insertDMapKey :: k a -> v a -> PatchDMapWithMove k v 208 | insertDMapKey k v = 209 | PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing) 210 | 211 | -- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to: 212 | -- 213 | -- @ 214 | -- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap)) 215 | -- @ 216 | moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v 217 | moveDMapKey src dst = case src `geq` dst of 218 | Nothing -> PatchDMapWithMove $ DMap.fromList 219 | [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing) 220 | , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst) 221 | ] 222 | Just _ -> mempty 223 | 224 | -- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: 225 | -- 226 | -- @ 227 | -- let aMay = DMap.lookup a dmap 228 | -- bMay = DMap.lookup b dmap 229 | -- in maybe id (DMap.insert a) (bMay <> aMay) 230 | -- . maybe id (DMap.insert b) (aMay <> bMay) 231 | -- . DMap.delete a . DMap.delete b $ dmap 232 | -- @ 233 | swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v 234 | swapDMapKey src dst = case src `geq` dst of 235 | Nothing -> PatchDMapWithMove $ DMap.fromList 236 | [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src) 237 | , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst) 238 | ] 239 | Just _ -> mempty 240 | 241 | -- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'. 242 | deleteDMapKey :: k a -> PatchDMapWithMove k v 243 | deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing 244 | 245 | {- 246 | k1, k2 :: Const2 Int () () 247 | k1 = Const2 1 248 | k2 = Const2 2 249 | p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity 250 | p1 = moveDMapKey k1 k2 251 | p2 = moveDMapKey k2 k1 252 | p12 = p1 <> p2 253 | p21 = p2 <> p1 254 | p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2 255 | p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1 256 | 257 | testPatchDMapWithMove = do 258 | print p1 259 | print p2 260 | print $ p12 == deleteDMapKey k1 261 | print $ p21 == deleteDMapKey k2 262 | print $ p12Slow == deleteDMapKey k1 263 | print $ p21Slow == deleteDMapKey k2 264 | 265 | dst (PatchDMapWithMove x _) = x 266 | src (PatchDMapWithMove _ x) = x 267 | -} 268 | 269 | -- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'. 270 | unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v) 271 | unPatchDMapWithMove (PatchDMapWithMove p) = p 272 | 273 | -- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants. 274 | -- 275 | -- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked. 276 | unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v 277 | unsafePatchDMapWithMove = PatchDMapWithMove 278 | 279 | -- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned 280 | -- otherwise @Left errors@. 281 | patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v) 282 | patchDMapWithMove dm = 283 | case validationErrorsForPatchDMapWithMove dm of 284 | [] -> Right $ unsafePatchDMapWithMove dm 285 | errs -> Left errs 286 | 287 | -- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@. 288 | mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v' 289 | mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ 290 | DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p 291 | where g :: forall a. From k v a -> From k v' a 292 | g = \case 293 | From_Insert v -> From_Insert $ f v 294 | From_Delete -> From_Delete 295 | From_Move k -> From_Move k 296 | 297 | -- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@. 298 | traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v') 299 | traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f 300 | 301 | -- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@. 302 | traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v') 303 | traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p 304 | where g :: forall a. k a -> From k v a -> m (From k v' a) 305 | g k = \case 306 | From_Insert v -> From_Insert <$> f k v 307 | From_Delete -> pure From_Delete 308 | From_Move fromKey -> pure $ From_Move fromKey 309 | 310 | -- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@. 311 | nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a 312 | nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni } 313 | 314 | -- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@. 315 | nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a) 316 | nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni 317 | 318 | -- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to 319 | -- values. 320 | weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v' 321 | weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p 322 | where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v' 323 | g ni = MapWithMove.NodeInfo 324 | { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of 325 | From_Insert v -> MapWithMove.From_Insert $ f v 326 | From_Delete -> MapWithMove.From_Delete 327 | From_Move k -> MapWithMove.From_Move $ mkSome k 328 | , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni) 329 | } 330 | 331 | -- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any 332 | -- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank. 333 | patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v' 334 | patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p 335 | where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v' 336 | g ni = MapWithMove.NodeInfo 337 | { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of 338 | From_Insert v -> MapWithMove.From_Insert $ f v 339 | From_Delete -> MapWithMove.From_Delete 340 | From_Move (Const2 k) -> MapWithMove.From_Move k 341 | , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni) 342 | } 343 | 344 | -- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed 345 | -- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@. 346 | -- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith' 347 | const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v' 348 | const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p 349 | where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v') 350 | g (k, ni) = Const2 k :=> NodeInfo 351 | { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of 352 | MapWithMove.From_Insert v -> From_Insert $ f v 353 | MapWithMove.From_Delete -> From_Delete 354 | MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey 355 | , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni 356 | } 357 | 358 | -- | Apply the insertions, deletions, and moves to a given 'DMap'. 359 | instance GCompare k => Patch (PatchDMapWithMove k v) where 360 | type PatchTarget (PatchDMapWithMove k v) = DMap k v 361 | apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? 362 | where insertions = DMap.mapMaybeWithKey insertFunc p 363 | insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a) 364 | insertFunc _ ni = case _nodeInfo_from ni of 365 | From_Insert v -> Just v 366 | From_Move k -> DMap.lookup k old 367 | From_Delete -> Nothing 368 | deletions = DMap.mapMaybeWithKey deleteFunc p 369 | deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a) 370 | deleteFunc _ ni = case _nodeInfo_from ni of 371 | From_Delete -> Just $ Constant () 372 | _ -> Nothing 373 | 374 | -- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'. 375 | getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k)) 376 | getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p 377 | where f _ v ni = Pair v $ _nodeInfo_to ni 378 | -------------------------------------------------------------------------------- /src/Data/Patch/IntMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | {-| 12 | Description: Module containing 'PatchIntMap', a 'Patch' for 'IntMap'. 13 | 14 | Patches of this sort allow for insert/update or delete of associations. 15 | -} 16 | module Data.Patch.IntMap where 17 | 18 | import Control.Lens hiding (FunctorWithIndex, FoldableWithIndex, TraversableWithIndex) 19 | #if !MIN_VERSION_lens(5,0,0) 20 | import qualified Control.Lens as L 21 | #endif 22 | import Data.IntMap.Strict (IntMap) 23 | import qualified Data.IntMap.Strict as IntMap 24 | import Data.Maybe 25 | import Data.Monoid.DecidablyEmpty 26 | #if !MIN_VERSION_base(4,11,0) 27 | import Data.Semigroup (Semigroup (..)) 28 | #endif 29 | import Data.Patch.Class 30 | import Data.Functor.WithIndex 31 | import Data.Foldable.WithIndex 32 | import Data.Traversable.WithIndex 33 | 34 | -- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping. 35 | -- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update 36 | -- and @Nothing@ means delete. 37 | newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) } 38 | deriving ( Show, Read, Eq, Ord 39 | , Functor, Foldable, Traversable 40 | , Monoid, DecidablyEmpty 41 | ) 42 | 43 | -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. 44 | -- If the same key is modified by both patches, the one on the left will take 45 | -- precedence. 46 | deriving instance Semigroup (PatchIntMap v) 47 | 48 | makeWrapped ''PatchIntMap 49 | 50 | -- | Apply the insertions or deletions to a given 'IntMap'. 51 | instance Patch (PatchIntMap a) where 52 | type PatchTarget (PatchIntMap a) = IntMap a 53 | apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $ 54 | let removes = IntMap.filter isNothing p 55 | adds = IntMap.mapMaybe id p 56 | in IntMap.union adds $ v `IntMap.difference` removes 57 | 58 | instance FunctorWithIndex Int PatchIntMap 59 | instance FoldableWithIndex Int PatchIntMap 60 | instance TraversableWithIndex Int PatchIntMap where 61 | itraverse = (_Wrapped .> itraversed <. traversed) . Indexed 62 | 63 | #if !MIN_VERSION_lens(5,0,0) 64 | instance L.FunctorWithIndex Int PatchIntMap where imap = Data.Functor.WithIndex.imap 65 | instance L.FoldableWithIndex Int PatchIntMap where ifoldMap = Data.Foldable.WithIndex.ifoldMap 66 | instance L.TraversableWithIndex Int PatchIntMap where itraverse = Data.Traversable.WithIndex.itraverse 67 | #endif 68 | 69 | -- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@ 70 | -- (that is, all inserts/updates), producing a @PatchIntMap b@. 71 | mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b 72 | mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m 73 | 74 | -- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@ 75 | -- (that is, all inserts/updates), producing a @f (PatchIntMap b)@. 76 | traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b) 77 | traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (traverse . f) m 78 | 79 | -- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@. 80 | patchIntMapNewElements :: PatchIntMap a -> [a] 81 | patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m 82 | 83 | -- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all 84 | -- the inserts/updates in the given patch. 85 | patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a 86 | patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m 87 | 88 | -- | Subset the given @'IntMap' a@ to contain only the keys that would be 89 | -- deleted by the given @'PatchIntMap' a@. 90 | getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v' 91 | getDeletions (PatchIntMap m) v = IntMap.intersection v m 92 | -------------------------------------------------------------------------------- /src/Data/Patch/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | {-| 13 | Description: A basic 'Patch' on 'Map' 14 | 15 | Patches of this type consist only of insertions (including overwrites) and 16 | deletions. 17 | -} 18 | module Data.Patch.Map where 19 | 20 | import Data.Patch.Class 21 | 22 | import Control.Lens hiding (FunctorWithIndex, FoldableWithIndex, TraversableWithIndex) 23 | #if !MIN_VERSION_lens(5,0,0) 24 | import qualified Control.Lens as L 25 | #endif 26 | import Data.Map (Map) 27 | import qualified Data.Map as Map 28 | import Data.Maybe 29 | import Data.Monoid.DecidablyEmpty 30 | import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) 31 | import Data.Functor.WithIndex 32 | import Data.Foldable.WithIndex 33 | import Data.Traversable.WithIndex 34 | 35 | -- | A set of changes to a 'Map'. Any element may be inserted/updated or 36 | -- deleted. Insertions are represented as values wrapped in 'Just', while 37 | -- deletions are represented as 'Nothing's 38 | newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) } 39 | deriving ( Show, Read, Eq, Ord 40 | , Foldable, Traversable 41 | , DecidablyEmpty 42 | ) 43 | 44 | -- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert. 45 | -- Deletions are unaffected. 46 | deriving instance Functor (PatchMap k) 47 | -- | The empty 'PatchMap' contains no insertions or deletions 48 | deriving instance Ord k => Monoid (PatchMap k v) 49 | 50 | -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. 51 | -- If the same key is modified by both patches, the one on the left will take 52 | -- precedence. 53 | instance Ord k => Semigroup (PatchMap k v) where 54 | PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map 55 | -- PatchMap is idempotent, so stimes n is id for every n 56 | stimes = stimesIdempotentMonoid 57 | 58 | -- | Apply the insertions or deletions to a given 'Map'. 59 | instance Ord k => Patch (PatchMap k v) where 60 | type PatchTarget (PatchMap k v) = Map k v 61 | {-# INLINABLE apply #-} 62 | apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? 63 | where insertions = Map.mapMaybeWithKey (const id) p 64 | deletions = Map.mapMaybeWithKey (const nothingToJust) p 65 | nothingToJust = \case 66 | Nothing -> Just () 67 | Just _ -> Nothing 68 | 69 | makeWrapped ''PatchMap 70 | 71 | instance FunctorWithIndex k (PatchMap k) 72 | instance FoldableWithIndex k (PatchMap k) 73 | instance TraversableWithIndex k (PatchMap k) where 74 | itraverse = (_Wrapped .> itraversed <. traversed) . Indexed 75 | 76 | #if !MIN_VERSION_lens(5,0,0) 77 | instance L.FunctorWithIndex k (PatchMap k) where imap = Data.Functor.WithIndex.imap 78 | instance L.FoldableWithIndex k (PatchMap k) where ifoldMap = Data.Foldable.WithIndex.ifoldMap 79 | instance L.TraversableWithIndex k (PatchMap k) where itraverse = Data.Traversable.WithIndex.itraverse 80 | #endif 81 | 82 | -- | Returns all the new elements that will be added to the 'Map' 83 | patchMapNewElements :: PatchMap k v -> [v] 84 | patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p 85 | 86 | -- | Returns all the new elements that will be added to the 'Map' 87 | patchMapNewElementsMap :: PatchMap k v -> Map k v 88 | patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p 89 | -------------------------------------------------------------------------------- /src/Data/Patch/MapWithMove.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PatternGuards #-} 9 | {-# LANGUAGE PatternSynonyms #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE ViewPatterns #-} 17 | 18 | {-| 19 | Description: An intermediate 'Patch' on 'Map' 20 | 21 | Patches of this type can insert, delete, and also move values from one key to 22 | another. 23 | -} 24 | module Data.Patch.MapWithMove 25 | ( PatchMapWithMove 26 | ( PatchMapWithMove 27 | , unPatchMapWithMove 28 | , .. 29 | ) 30 | , patchMapWithMove 31 | , patchMapWithMoveInsertAll 32 | , insertMapKey 33 | , moveMapKey 34 | , swapMapKey 35 | , deleteMapKey 36 | , unsafePatchMapWithMove 37 | , patchMapWithMoveNewElements 38 | , patchMapWithMoveNewElementsMap 39 | , patchThatSortsMapWith 40 | , patchThatChangesAndSortsMapWith 41 | , patchThatChangesMap 42 | 43 | -- * Node Info 44 | , NodeInfo 45 | ( NodeInfo 46 | , _nodeInfo_from 47 | , _nodeInfo_to 48 | , .. 49 | ) 50 | , bitraverseNodeInfo 51 | , nodeInfoMapFrom 52 | , nodeInfoMapMFrom 53 | , nodeInfoSetTo 54 | 55 | -- * From 56 | , From 57 | ( From_Insert 58 | , From_Delete 59 | , From_Move 60 | , .. 61 | ) 62 | , bitraverseFrom 63 | 64 | -- * To 65 | , To 66 | ) where 67 | 68 | import Data.Coerce 69 | import Data.Kind (Type) 70 | import Data.Patch.Class 71 | import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To) 72 | import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym 73 | 74 | import Control.Lens hiding (FunctorWithIndex, FoldableWithIndex, TraversableWithIndex) 75 | #if !MIN_VERSION_lens(5,0,0) 76 | import qualified Control.Lens as L 77 | #endif 78 | import Data.List 79 | import Data.Map (Map) 80 | import qualified Data.Map as Map 81 | import Data.Proxy 82 | #if !MIN_VERSION_base(4,11,0) 83 | import Data.Semigroup (Semigroup (..)) 84 | #endif 85 | import Data.Traversable (foldMapDefault) 86 | import Data.Functor.WithIndex 87 | import Data.Foldable.WithIndex 88 | import Data.Traversable.WithIndex 89 | 90 | -- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@ 91 | -- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@, 92 | -- and vice versa. There should never be any unpaired From/To keys. 93 | newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove' 94 | { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)' 95 | unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v) 96 | } 97 | deriving ( Show, Read, Eq, Ord 98 | -- Haddock cannot handle documentation here before GHC 8.6 99 | , 100 | #if __GLASGOW_HASKELL__ >= 806 101 | -- | Compose patches having the same effect as applying the 102 | -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 103 | -- 'applyAlways' q@ 104 | #endif 105 | Semigroup 106 | , Monoid 107 | ) 108 | 109 | pattern Coerce :: Coercible a b => a -> b 110 | pattern Coerce x <- (coerce -> x) 111 | where Coerce x = coerce x 112 | 113 | {-# COMPLETE PatchMapWithMove #-} 114 | pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v 115 | -- | Extract the representation of the t'PatchMapWithMove' as a map of 116 | -- t'NodeInfo'. 117 | unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v) 118 | pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove)) 119 | 120 | _PatchMapWithMove 121 | :: Iso 122 | (PatchMapWithMove k0 v0) 123 | (PatchMapWithMove k1 v1) 124 | (Map k0 (NodeInfo k0 v0)) 125 | (Map k1 (NodeInfo k1 v1)) 126 | _PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove 127 | 128 | instance Functor (PatchMapWithMove k) where 129 | fmap f = runIdentity . traverse (Identity . f) 130 | 131 | instance Foldable (PatchMapWithMove k) where 132 | foldMap = foldMapDefault 133 | 134 | instance Traversable (PatchMapWithMove k) where 135 | traverse = 136 | _PatchMapWithMove . 137 | traverse . 138 | traverse 139 | 140 | instance FunctorWithIndex k (PatchMapWithMove k) 141 | instance FoldableWithIndex k (PatchMapWithMove k) 142 | instance TraversableWithIndex k (PatchMapWithMove k) where 143 | itraverse = (_PatchMapWithMove .> itraversed <. traverse) . Indexed 144 | 145 | #if !MIN_VERSION_lens(5,0,0) 146 | instance L.FunctorWithIndex k (PatchMapWithMove k) where imap = Data.Functor.WithIndex.imap 147 | instance L.FoldableWithIndex k (PatchMapWithMove k) where ifoldMap = Data.Foldable.WithIndex.ifoldMap 148 | instance L.TraversableWithIndex k (PatchMapWithMove k) where itraverse = Data.Traversable.WithIndex.itraverse 149 | #endif 150 | 151 | -- | Create a t'PatchMapWithMove', validating it 152 | patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v) 153 | patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce 154 | 155 | -- | Create a t'PatchMapWithMove' that inserts everything in the given 'Map' 156 | patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v 157 | patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll 158 | 159 | -- | Make a @t'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'. 160 | insertMapKey :: k -> v -> PatchMapWithMove k v 161 | insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v 162 | 163 | -- |Make a @t'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to: 164 | -- 165 | -- @ 166 | -- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map)) 167 | -- @ 168 | moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v 169 | moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst 170 | 171 | -- |Make a @t'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: 172 | -- 173 | -- @ 174 | -- let aMay = Map.lookup a map 175 | -- bMay = Map.lookup b map 176 | -- in maybe id (Map.insert a) (bMay <> aMay) 177 | -- . maybe id (Map.insert b) (aMay <> bMay) 178 | -- . Map.delete a . Map.delete b $ map 179 | -- @ 180 | swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v 181 | swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst 182 | 183 | -- |Make a @t'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'. 184 | deleteMapKey :: k -> PatchMapWithMove k v 185 | deleteMapKey = PatchMapWithMove' . PM.deleteMapKey 186 | 187 | -- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @t'PatchMapWithMove' k v@, without checking any invariants. 188 | -- 189 | -- __Warning:__ when using this function, you must ensure that the invariants of t'PatchMapWithMove' are preserved; they will not be checked. 190 | unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v 191 | unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove 192 | 193 | -- | Apply the insertions, deletions, and moves to a given 'Map' 194 | instance Ord k => Patch (PatchMapWithMove k v) where 195 | type PatchTarget (PatchMapWithMove k v) = Map k v 196 | apply (PatchMapWithMove' p) = apply p 197 | 198 | -- | Returns all the new elements that will be added to the 'Map'. 199 | patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v] 200 | patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove' 201 | 202 | -- | Return a @'Map' k v@ with all the inserts/updates from the given @t'PatchMapWithMove' k v@. 203 | patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v 204 | patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove' 205 | 206 | -- | Create a t'PatchMapWithMove' that, if applied to the given 'Map', will sort 207 | -- its values using the given ordering function. The set keys of the 'Map' is 208 | -- not changed. 209 | patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v 210 | patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp 211 | 212 | -- | Create a t'PatchMapWithMove' that, if applied to the first 'Map' provided, 213 | -- will produce a 'Map' with the same values as the second 'Map' but with the 214 | -- values sorted with the given ordering function. 215 | patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v 216 | patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex 217 | where newList = Map.toList newByIndexUnsorted 218 | newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList 219 | 220 | -- | Create a t'PatchMapWithMove' that, if applied to the first 'Map' provided, 221 | -- will produce the second 'Map'. 222 | patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v 223 | patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $ 224 | PM.patchThatChangesMap oldByIndex newByIndex 225 | 226 | -- 227 | -- NodeInfo 228 | -- 229 | 230 | -- | Holds the information about each key: where its new value should come from, 231 | -- and where its old value should go to 232 | newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) } 233 | 234 | deriving instance (Show k, Show p) => Show (NodeInfo k p) 235 | deriving instance (Read k, Read p) => Read (NodeInfo k p) 236 | deriving instance (Eq k, Eq p) => Eq (NodeInfo k p) 237 | deriving instance (Ord k, Ord p) => Ord (NodeInfo k p) 238 | 239 | {-# COMPLETE NodeInfo #-} 240 | pattern NodeInfo :: From k v -> To k -> NodeInfo k v 241 | _nodeInfo_from :: NodeInfo k v -> From k v 242 | _nodeInfo_to :: NodeInfo k v -> To k 243 | pattern NodeInfo { _nodeInfo_from, _nodeInfo_to } = NodeInfo' 244 | PM.NodeInfo 245 | { PM._nodeInfo_from = Coerce _nodeInfo_from 246 | , PM._nodeInfo_to = _nodeInfo_to 247 | } 248 | 249 | _NodeInfo 250 | :: Iso 251 | (NodeInfo k0 v0) 252 | (NodeInfo k1 v1) 253 | (PM.NodeInfo k0 (Proxy v0)) 254 | (PM.NodeInfo k1 (Proxy v1)) 255 | _NodeInfo = iso unNodeInfo' NodeInfo' 256 | 257 | instance Functor (NodeInfo k) where 258 | fmap f = runIdentity . traverse (Identity . f) 259 | 260 | instance Foldable (NodeInfo k) where 261 | foldMap = foldMapDefault 262 | 263 | instance Traversable (NodeInfo k) where 264 | traverse = bitraverseNodeInfo pure 265 | 266 | -- | Like 'Data.Bitraversable.bitraverse' 267 | bitraverseNodeInfo 268 | :: Applicative f 269 | => (k0 -> f k1) 270 | -> (v0 -> f v1) 271 | -> NodeInfo k0 v0 -> f (NodeInfo k1 v1) 272 | bitraverseNodeInfo fk fv = fmap NodeInfo' 273 | . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv 274 | . coerce 275 | 276 | -- | Change the 'From' value of a t'NodeInfo' 277 | nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v 278 | nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From') 279 | 280 | -- | Change the 'From' value of a t'NodeInfo', using a 'Functor' (or 281 | -- 'Applicative', 'Monad', etc.) action to get the new value 282 | nodeInfoMapMFrom 283 | :: Functor f 284 | => (From k v -> f (From k v)) 285 | -> NodeInfo k v -> f (NodeInfo k v) 286 | nodeInfoMapMFrom f = fmap NodeInfo' 287 | . PM.nodeInfoMapMFrom (fmap unFrom' . f . From') 288 | . coerce 289 | 290 | -- | Set the 'To' field of a t'NodeInfo' 291 | nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v 292 | nodeInfoSetTo = coerce . PM.nodeInfoSetTo 293 | 294 | -- 295 | -- From 296 | -- 297 | 298 | -- | Describe how a key's new value should be produced 299 | newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) } 300 | 301 | {-# COMPLETE From_Insert, From_Delete, From_Move #-} 302 | 303 | -- | Insert the given value here 304 | pattern From_Insert :: v -> From k v 305 | pattern From_Insert v = From' (PM.From_Insert v) 306 | 307 | -- | Delete the existing value, if any, from here 308 | pattern From_Delete :: From k v 309 | pattern From_Delete = From' PM.From_Delete 310 | 311 | -- | Move the value here from the given key 312 | pattern From_Move :: k -> From k v 313 | pattern From_Move k = From' (PM.From_Move k Proxy) 314 | 315 | -- | Like 'Data.Bitraversable.bitraverse' 316 | bitraverseFrom 317 | :: Applicative f 318 | => (k0 -> f k1) 319 | -> (v0 -> f v1) 320 | -> From k0 v0 -> f (From k1 v1) 321 | bitraverseFrom fk fv = fmap From' 322 | . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv 323 | . coerce 324 | 325 | makeWrapped ''PatchMapWithMove 326 | makeWrapped ''NodeInfo 327 | makeWrapped ''From 328 | -------------------------------------------------------------------------------- /src/Data/Patch/MapWithPatchingMove.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PatternGuards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {-| 16 | Description: An advanced 'Patch' on 'Map' 17 | 18 | Patches of this type can can insert, delete, and move values from one key to 19 | another, and move patches may also additionally patch the value being moved. 20 | -} 21 | module Data.Patch.MapWithPatchingMove 22 | ( PatchMapWithPatchingMove (..) 23 | , patchMapWithPatchingMove 24 | , patchMapWithPatchingMoveInsertAll 25 | , insertMapKey 26 | , moveMapKey 27 | , patchMapKey 28 | , swapMapKey 29 | , deleteMapKey 30 | , unsafePatchMapWithPatchingMove 31 | , patchMapWithPatchingMoveNewElements 32 | , patchMapWithPatchingMoveNewElementsMap 33 | , patchThatSortsMapWith 34 | , patchThatChangesAndSortsMapWith 35 | , patchThatChangesMap 36 | 37 | -- * Node Info 38 | , NodeInfo (..) 39 | , bitraverseNodeInfo 40 | , nodeInfoMapFrom 41 | , nodeInfoMapMFrom 42 | , nodeInfoSetTo 43 | 44 | -- * From 45 | , From(..) 46 | , bitraverseFrom 47 | 48 | -- * To 49 | , To 50 | 51 | -- TODO internals module 52 | , Fixup (..) 53 | ) where 54 | 55 | import Data.Patch.Class 56 | 57 | import Control.Lens ((<&>)) 58 | import Control.Lens.TH (makeWrapped) 59 | import Data.Align (align) 60 | import Data.Foldable (toList) 61 | import Data.Function 62 | import Data.List 63 | import Data.Map (Map) 64 | import qualified Data.Map as Map 65 | import Data.Maybe 66 | #if !MIN_VERSION_base(4,11,0) 67 | import Data.Semigroup (Semigroup (..)) 68 | #endif 69 | import Data.Monoid.DecidablyEmpty 70 | import Data.Set (Set) 71 | import qualified Data.Set as Set 72 | import Data.These (These (..)) 73 | 74 | -- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@ 75 | -- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@, 76 | -- and vice versa. There should never be any unpaired From/To keys. 77 | newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove 78 | { -- | Extract the internal representation of the 'PatchMapWithPatchingMove' 79 | unPatchMapWithPatchingMove :: Map k (NodeInfo k p) 80 | } 81 | 82 | deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p) 83 | deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p) 84 | deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p) 85 | deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p) 86 | 87 | deriving instance ( Ord k 88 | #if !MIN_VERSION_base(4,11,0) 89 | , Semigroup p 90 | #endif 91 | , DecidablyEmpty p 92 | , Patch p 93 | ) => DecidablyEmpty (PatchMapWithPatchingMove k p) 94 | 95 | -- | Create a 'PatchMapWithPatchingMove', validating it 96 | patchMapWithPatchingMove 97 | :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p) 98 | patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing 99 | where valid = forwardLinks == backwardLinks 100 | forwardLinks = Map.mapMaybe _nodeInfo_to m 101 | backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) -> 102 | case _nodeInfo_from p of 103 | From_Move from _ -> Just (from, to) 104 | _ -> Nothing 105 | 106 | -- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map' 107 | patchMapWithPatchingMoveInsertAll 108 | :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p 109 | patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo 110 | { _nodeInfo_from = From_Insert v 111 | , _nodeInfo_to = Nothing 112 | } 113 | 114 | -- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'. 115 | insertMapKey 116 | :: k -> PatchTarget p -> PatchMapWithPatchingMove k p 117 | insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing 118 | 119 | -- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to: 120 | -- 121 | -- @ 122 | -- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map)) 123 | -- @ 124 | moveMapKey 125 | :: ( DecidablyEmpty p 126 | #if !MIN_VERSION_base(4,11,0) 127 | , Semigroup p 128 | #endif 129 | , Patch p 130 | ) 131 | => Ord k => k -> k -> PatchMapWithPatchingMove k p 132 | moveMapKey src dst 133 | | src == dst = mempty 134 | | otherwise = 135 | PatchMapWithPatchingMove $ Map.fromList 136 | [ (dst, NodeInfo (From_Move src mempty) Nothing) 137 | , (src, NodeInfo From_Delete (Just dst)) 138 | ] 139 | 140 | patchMapKey 141 | :: ( DecidablyEmpty p 142 | #if !MIN_VERSION_base(4,11,0) 143 | , Semigroup p 144 | #endif 145 | ) 146 | => k -> p -> PatchMapWithPatchingMove k p 147 | patchMapKey k p 148 | | isEmpty p = PatchMapWithPatchingMove Map.empty 149 | | otherwise = 150 | PatchMapWithPatchingMove $ Map.singleton k $ NodeInfo (From_Move k p) (Just k) 151 | 152 | -- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to: 153 | -- 154 | -- @ 155 | -- let aMay = Map.lookup a map 156 | -- bMay = Map.lookup b map 157 | -- in maybe id (Map.insert a) (bMay <> aMay) 158 | -- . maybe id (Map.insert b) (aMay <> bMay) 159 | -- . Map.delete a . Map.delete b $ map 160 | -- @ 161 | swapMapKey 162 | :: ( DecidablyEmpty p 163 | #if !MIN_VERSION_base(4,11,0) 164 | , Semigroup p 165 | #endif 166 | , Patch p 167 | ) 168 | => Ord k => k -> k -> PatchMapWithPatchingMove k p 169 | swapMapKey src dst 170 | | src == dst = mempty 171 | | otherwise = 172 | PatchMapWithPatchingMove $ Map.fromList 173 | [ (dst, NodeInfo (From_Move src mempty) (Just src)) 174 | , (src, NodeInfo (From_Move dst mempty) (Just dst)) 175 | ] 176 | 177 | -- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in 178 | -- the mapping, equivalent to 'Map.delete'. 179 | deleteMapKey 180 | :: k -> PatchMapWithPatchingMove k v 181 | deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing 182 | 183 | -- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants. 184 | -- 185 | -- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked. 186 | unsafePatchMapWithPatchingMove 187 | :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p 188 | unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove 189 | 190 | -- | Apply the insertions, deletions, and moves to a given 'Map' 191 | instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where 192 | type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p) 193 | -- TODO: return Nothing sometimes 194 | -- Note: the strict application here is critical to ensuring that incremental 195 | -- merges don't hold onto all their prerequisite events forever; can we make 196 | -- this more robust? 197 | apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions) 198 | where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of 199 | From_Insert v -> Just v 200 | From_Move k p -> applyAlways p <$> Map.lookup k old 201 | From_Delete -> Nothing 202 | deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of 203 | From_Delete -> Just () 204 | _ -> Nothing 205 | 206 | -- | Returns all the new elements that will be added to the 'Map' 207 | patchMapWithPatchingMoveNewElements 208 | :: PatchMapWithPatchingMove k p -> [PatchTarget p] 209 | patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap 210 | 211 | -- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@. 212 | patchMapWithPatchingMoveNewElementsMap 213 | :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p) 214 | patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p 215 | where f ni = case _nodeInfo_from ni of 216 | From_Insert v -> Just v 217 | From_Move _ _ -> Nothing 218 | From_Delete -> Nothing 219 | 220 | -- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort 221 | -- its values using the given ordering function. The set keys of the 'Map' is 222 | -- not changed. 223 | patchThatSortsMapWith 224 | :: (Ord k, Monoid p) 225 | => (PatchTarget p -> PatchTarget p -> Ordering) 226 | -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p 227 | patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted 228 | where unsorted = Map.toList m 229 | sorted = sortBy (cmp `on` snd) unsorted 230 | f (to, _) (from, _) = if to == from then Nothing else 231 | Just (from, to) 232 | reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted 233 | g (to, _) (from, _) = if to == from then Nothing else 234 | let movingTo = fromMaybe err $ Map.lookup from reverseMapping 235 | in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo) 236 | err = error "IMPOSSIBLE happens in patchThatSortsMapWith" 237 | 238 | -- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided, 239 | -- will produce a 'Map' with the same values as the second 'Map' but with the 240 | -- values sorted with the given ordering function. 241 | patchThatChangesAndSortsMapWith 242 | :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p) 243 | => (PatchTarget p -> PatchTarget p -> Ordering) 244 | -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p 245 | patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex 246 | where newList = Map.toList newByIndexUnsorted 247 | newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList 248 | 249 | -- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided, 250 | -- will produce the second 'Map'. 251 | -- Note: this will never produce a patch on a value. 252 | patchThatChangesMap 253 | :: forall k p 254 | . (Ord k, Ord (PatchTarget p), Monoid p) 255 | => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p 256 | patchThatChangesMap oldByIndex newByIndex = patch 257 | where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k) 258 | invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList 259 | -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function 260 | unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v' 261 | unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys") 262 | unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) 263 | unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos) 264 | -- Generate patch info for a single value 265 | -- Keys that are found in both the old and new sets will not be patched 266 | -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted 267 | -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted 268 | patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k)) 269 | patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case 270 | This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it 271 | That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it 272 | These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK) 273 | -- Run patchSingleValue on a These. Missing old or new sets are considered empty 274 | patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k)) 275 | patchSingleValueThese v = \case 276 | This oldKeys -> patchSingleValue v oldKeys mempty 277 | That newKeys -> patchSingleValue v mempty newKeys 278 | These oldKeys newKeys -> patchSingleValue v oldKeys newKeys 279 | -- Generate froms and tos for all values, then merge them together 280 | (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex) 281 | patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case 282 | This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted. 283 | That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted 284 | These from to -> NodeInfo from to 285 | 286 | -- 287 | -- NodeInfo 288 | -- 289 | 290 | -- | Holds the information about each key: where its new value should come from, 291 | -- and where its old value should go to 292 | data NodeInfo k p = NodeInfo 293 | { _nodeInfo_from :: !(From k p) 294 | -- ^ Where do we get the new value for this key? 295 | , _nodeInfo_to :: !(To k) 296 | -- ^ If the old value is being kept (i.e. moved rather than deleted or 297 | -- replaced), where is it going? 298 | } 299 | deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p) 300 | deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p) 301 | deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p) 302 | deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p) 303 | 304 | -- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of 305 | -- the type families here, this doesn't it any bi- or tri-traversal class. 306 | bitraverseNodeInfo 307 | :: Applicative f 308 | => (k0 -> f k1) 309 | -> (p0 -> f p1) 310 | -> (PatchTarget p0 -> f (PatchTarget p1)) 311 | -> NodeInfo k0 p0 -> f (NodeInfo k1 p1) 312 | bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo 313 | <$> bitraverseFrom fk fp fpt from 314 | <*> traverse fk to 315 | 316 | -- | Change the 'From' value of a 'NodeInfo' 317 | nodeInfoMapFrom 318 | :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v 319 | nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni } 320 | 321 | -- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or 322 | -- 'Applicative', 'Monad', etc.) action to get the new value 323 | nodeInfoMapMFrom 324 | :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v) 325 | nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni 326 | 327 | -- | Set the 'To' field of a 'NodeInfo' 328 | nodeInfoSetTo 329 | :: To k -> NodeInfo k v -> NodeInfo k v 330 | nodeInfoSetTo to ni = ni { _nodeInfo_to = to } 331 | 332 | -- 333 | -- From 334 | -- 335 | 336 | -- | Describe how a key's new value should be produced 337 | data From k p 338 | = From_Insert (PatchTarget p) -- ^ Insert the given value here 339 | | From_Delete -- ^ Delete the existing value, if any, from here 340 | | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch 341 | 342 | deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p) 343 | deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p) 344 | deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p) 345 | deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p) 346 | 347 | -- | Traverse the 'From' over the key, patch, and patch target. Because of 348 | -- the type families here, this doesn't it any bi- or tri-traversal class. 349 | bitraverseFrom 350 | :: Applicative f 351 | => (k0 -> f k1) 352 | -> (p0 -> f p1) 353 | -> (PatchTarget p0 -> f (PatchTarget p1)) 354 | -> From k0 p0 -> f (From k1 p1) 355 | bitraverseFrom fk fp fpt = \case 356 | From_Insert pt -> From_Insert <$> fpt pt 357 | From_Delete -> pure From_Delete 358 | From_Move k p -> From_Move <$> fk k <*> fp p 359 | 360 | -- 361 | -- To 362 | -- 363 | 364 | -- | Describe where a key's old value will go. If this is 'Just', that means 365 | -- the key's old value will be moved to the given other key; if it is 'Nothing', 366 | -- that means it will be deleted. 367 | type To = Maybe 368 | 369 | -- 370 | -- Fixup 371 | -- 372 | 373 | -- | Helper data structure used for composing patches using the monoid instance. 374 | data Fixup k v 375 | = Fixup_Delete 376 | | Fixup_Update (These (From k v) (To k)) 377 | 378 | -- | Compose patches having the same effect as applying the patches in turn: 379 | -- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ 380 | instance ( Ord k 381 | #if !MIN_VERSION_base(4,11,0) 382 | , Semigroup p 383 | #endif 384 | , DecidablyEmpty p 385 | , Patch p 386 | ) => Semigroup (PatchMapWithPatchingMove k p) where 387 | PatchMapWithPatchingMove mNew <> PatchMapWithPatchingMove mOld = PatchMapWithPatchingMove m 388 | where 389 | connections = Map.elems $ Map.intersectionWithKey (\_ new old -> (_nodeInfo_to new, _nodeInfo_from old)) mNew mOld 390 | h :: (Maybe k, From k p) -> [(k, Fixup k p)] 391 | h = \case 392 | (Just toAfter, From_Move fromBefore p) 393 | | fromBefore == toAfter && isEmpty p 394 | -> [ (toAfter, Fixup_Delete) 395 | ] 396 | | otherwise 397 | -> [ (toAfter, Fixup_Update (This (From_Move fromBefore p))) 398 | , (fromBefore, Fixup_Update (That (Just toAfter))) 399 | ] 400 | (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That Nothing))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map 401 | (Just toAfter, editBefore) -> [(toAfter, Fixup_Update (This editBefore))] 402 | (Nothing, _) -> [] 403 | mergeFixups Fixup_Delete Fixup_Delete = Fixup_Delete 404 | mergeFixups (Fixup_Update a) (Fixup_Update b) 405 | | This x <- a, That y <- b 406 | = Fixup_Update $ These x y 407 | | That y <- a, This x <- b 408 | = Fixup_Update $ These x y 409 | mergeFixups _ _ = error "PatchMapWithPatchingMove: incompatible fixups" 410 | fixups = Map.fromListWithKey (\_ -> mergeFixups) $ concatMap h connections 411 | combineNodeInfos niNew niOld = NodeInfo 412 | { _nodeInfo_from = _nodeInfo_from niNew 413 | , _nodeInfo_to = _nodeInfo_to niOld 414 | } 415 | applyFixup ni = \case 416 | Fixup_Delete -> Nothing 417 | Fixup_Update u -> Just $ NodeInfo 418 | { _nodeInfo_from = case _nodeInfo_from ni of 419 | -- The new patch has a Move, so it could be affected by the 420 | -- corresponding From in the old patch. If that From exists, then 421 | -- it is in the fixup here. 422 | f@(From_Move _ p') -> case getHere u of 423 | -- If there's no `From` fixup, just use the "new" `From` 424 | Nothing -> f 425 | -- If there's a `From` fixup which is an Insert, we can just apply 426 | -- our patch to that and turn ourselves into an insert. 427 | Just (From_Insert v) -> From_Insert $ applyAlways p' v 428 | -- If there's a `From` fixup which is a Delete, then we can throw 429 | -- our patch away because there's nothing to apply it to and 430 | -- become a Delete ourselves. 431 | Just From_Delete -> From_Delete 432 | -- If there's a `From` fixup which is a Move, we need to apply 433 | -- both the old patch and the new patch (in that order) to the 434 | -- value, so we append the patches here. 435 | Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p 436 | -- If the new patch has an Insert, it doesn't care what the fixup 437 | -- value is, because it will overwrite it anyway. 438 | f@(From_Insert _) -> f 439 | -- If the new patch has an Delete, it doesn't care what the fixup 440 | -- value is, because it will overwrite it anyway. 441 | f@From_Delete -> f 442 | , _nodeInfo_to = case _nodeInfo_to ni of 443 | -- The old patch deletes this data, so we must delete it as well. 444 | -- According to the code above, any time we have this situation we 445 | -- should also have `getThere u == Nothing` because a fixup 446 | -- shouldn't be generated. 447 | Nothing -> Nothing 448 | -- The old patch sends the value to oldToAfter 449 | Just oldToAfter -> case getThere u of 450 | -- If there is no fixup, that should mean that the new patch 451 | -- doesn't do anything with the value in oldToAfter, so we still 452 | -- send it to oldToAfter 453 | Nothing -> Just oldToAfter 454 | -- If there is a fixup, it should tell us where the new patch 455 | -- sends the value at key oldToAfter. We send our value there. 456 | Just mNewToAfter -> mNewToAfter 457 | } 458 | m = Map.differenceWithKey (\_ -> applyFixup) (Map.unionWith combineNodeInfos mNew mOld) fixups 459 | getHere :: These a b -> Maybe a 460 | getHere = \case 461 | This a -> Just a 462 | These a _ -> Just a 463 | That _ -> Nothing 464 | getThere :: These a b -> Maybe b 465 | getThere = \case 466 | This _ -> Nothing 467 | These _ b -> Just b 468 | That b -> Just b 469 | 470 | --TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here 471 | -- | Compose patches having the same effect as applying the patches in turn: 472 | -- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ 473 | instance ( Ord k 474 | #if !MIN_VERSION_base(4,11,0) 475 | , Semigroup p 476 | #endif 477 | , DecidablyEmpty p 478 | , Patch p 479 | ) => Monoid (PatchMapWithPatchingMove k p) where 480 | mempty = PatchMapWithPatchingMove mempty 481 | mappend = (<>) 482 | 483 | makeWrapped ''PatchMapWithPatchingMove 484 | -------------------------------------------------------------------------------- /src/Data/Patch/PatchOrReplacement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | {-| 12 | Description: A 'Patch' combinator type for patching or replacing with a separate new value. 13 | -} 14 | module Data.Patch.PatchOrReplacement 15 | ( PatchOrReplacement (..) 16 | , _PatchOrReplacement_Patch 17 | , _PatchOrReplacement_Replacement 18 | , traversePatchOrReplacement 19 | ) where 20 | 21 | import Control.Lens.TH (makePrisms) 22 | import Data.Patch 23 | #if !MIN_VERSION_base(4,11,0) 24 | import Data.Semigroup (Semigroup (..)) 25 | #endif 26 | import GHC.Generics 27 | 28 | -- | Either a patch or a replacement value. 29 | -- 30 | -- A good patch type will describe small changes very efficiently, but 31 | -- that often comes at the cost of describing large change rather 32 | -- inefficiently. 'PatchOrReplacement' can be used as an escape hatch: 33 | -- when the change as a patch would be too big, just provide a new value 34 | -- to replace the old one with instead. 35 | -- 36 | -- @since 0.0.6 37 | data PatchOrReplacement p 38 | = PatchOrReplacement_Patch p 39 | | PatchOrReplacement_Replacement (PatchTarget p) 40 | deriving (Generic) 41 | 42 | deriving instance (Eq p, Eq (PatchTarget p)) => Eq (PatchOrReplacement p) 43 | deriving instance (Ord p, Ord (PatchTarget p)) => Ord (PatchOrReplacement p) 44 | deriving instance (Show p, Show (PatchTarget p)) => Show (PatchOrReplacement p) 45 | deriving instance (Read p, Read (PatchTarget p)) => Read (PatchOrReplacement p) 46 | 47 | -- | Traverse a 'PatchOrReplacement' with a function for each case 48 | traversePatchOrReplacement 49 | :: Functor f 50 | => (a -> f b) 51 | -> (PatchTarget a -> f (PatchTarget b)) 52 | -> PatchOrReplacement a -> f (PatchOrReplacement b) 53 | traversePatchOrReplacement f g = \case 54 | PatchOrReplacement_Patch p -> PatchOrReplacement_Patch <$> f p 55 | PatchOrReplacement_Replacement p -> PatchOrReplacement_Replacement <$> g p 56 | 57 | -- | To apply a @'PatchOrReplacement' p@ apply the the underlying @p@ or 58 | -- substitute the replacement @'PatchTarget' p@. 59 | instance Patch p => Patch (PatchOrReplacement p) where 60 | type PatchTarget (PatchOrReplacement p) = PatchTarget p 61 | apply = \case 62 | PatchOrReplacement_Patch p -> apply p 63 | PatchOrReplacement_Replacement v -> \_ -> Just v 64 | 65 | instance ( Monoid p 66 | #if !MIN_VERSION_base(4,11,0) 67 | , Semigroup p 68 | #endif 69 | , Patch p 70 | ) => Monoid (PatchOrReplacement p) where 71 | mempty = PatchOrReplacement_Patch mempty 72 | mappend = (<>) 73 | 74 | instance (Semigroup p, Patch p) => Semigroup (PatchOrReplacement p) where 75 | (<>) = curry $ \case 76 | (PatchOrReplacement_Patch a, PatchOrReplacement_Patch b) -> PatchOrReplacement_Patch $ a <> b 77 | (PatchOrReplacement_Patch a, PatchOrReplacement_Replacement b) -> PatchOrReplacement_Replacement $ applyAlways a b 78 | (PatchOrReplacement_Replacement a, _) -> PatchOrReplacement_Replacement a 79 | 80 | makePrisms ''PatchOrReplacement 81 | -------------------------------------------------------------------------------- /src/Data/Semigroup/Additive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | 3 | {-| 4 | Description : A deprecated module containing a deprecated alias to the class for commutative semigroups 5 | -} 6 | module Data.Semigroup.Additive 7 | {-# DEPRECATED "Use 'Data.Semigroup.Commutative'" #-} 8 | ( Additive 9 | ) where 10 | 11 | import Data.Semigroup.Commutative 12 | 13 | {-# DEPRECATED Additive "Use 'Data.Semigroup.Commutative.Commutative'" #-} 14 | -- | Deprecated alias for 'Commutative' 15 | type Additive = Commutative 16 | -------------------------------------------------------------------------------- /stylize: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | for x in **/*.hs ; do stylish-haskell -i "$x" ; done 5 | -------------------------------------------------------------------------------- /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 | , "--cpp-define=USE_TEMPLATE_HASKELL" 25 | , "--ignore=Use tuple-section" 26 | , "--ignore=Unused LANGUAGE pragma" -- hlint3 falsely believes that TypeOperators is not needed 27 | ] 28 | recurseInto = and <$> sequence 29 | [ fileType ==? Directory 30 | , fileName /=? ".git" 31 | ] 32 | matchFile = and <$> sequence 33 | [ extension ==? ".hs" 34 | ] 35 | files <- find recurseInto matchFile (pwd "src") --TODO: Someday fix all hints in tests, etc. 36 | ideas <- fmap concat $ forM files $ \f -> do 37 | putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... " 38 | runHlint f 39 | if null ideas then exitSuccess else exitFailure 40 | -------------------------------------------------------------------------------- /test/tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Main where 4 | 5 | import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test) 6 | import Data.Patch ( Patch(apply) ) 7 | import Data.Patch.MapWithMove ( patchThatChangesMap ) 8 | import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove) 9 | import qualified Data.Patch.MapWithPatchingMove as PatchMapWithPatchingMove 10 | import Data.Map as Map ( Map, fromList, singleton ) 11 | import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===)) 12 | import Hedgehog.Gen as Gen ( int ) 13 | import Hedgehog.Range as Range ( linear ) 14 | import Control.Monad (replicateM) 15 | import System.Exit (exitFailure, exitSuccess) 16 | import Data.Sequence as Seq ( foldMapWithIndex, replicateM ) 17 | import Data.Semigroup 18 | ( Sum (..) 19 | #if !MIN_VERSION_base(4,11,0) 20 | , Semigroup(..) 21 | #endif 22 | ) 23 | 24 | main :: IO () 25 | main = do 26 | counts <- runTestTT $ test 27 | [ "Simple Move" ~: do 28 | let mapBefore = Map.fromList [(0,1)] 29 | mapAfter = Map.fromList [(0,0),(1,1)] 30 | patch = patchThatChangesMap mapBefore mapAfter 31 | afterPatch = apply patch mapBefore 32 | assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch 33 | , "Property Checks" ~: propertyChecks 34 | , "Insert and Patch" ~: do 35 | let i :: PatchMapWithPatchingMove () (Sum Int) 36 | i = PatchMapWithPatchingMove.insertMapKey () 1 37 | p = PatchMapWithPatchingMove.patchMapKey () (Sum 2) 38 | pAfterI = PatchMapWithPatchingMove.insertMapKey () 3 39 | assertEqual "Insert after patch is the same as insert" (i <> p) i 40 | assertEqual "Patch after insert is a patched insert" (p <> i) pAfterI 41 | ] 42 | if errors counts + failures counts == 0 then exitSuccess else exitFailure 43 | 44 | propertyChecks :: IO Bool 45 | propertyChecks = checkParallel $$(discover) 46 | 47 | prop_patchThatChangesMap :: Property 48 | prop_patchThatChangesMap = property $ do 49 | mapBefore <- makeRandomIntMap 50 | mapAfter <- makeRandomIntMap 51 | let patch = patchThatChangesMap mapBefore mapAfter 52 | Just mapAfter === apply patch mapBefore 53 | 54 | makeRandomIntMap :: Monad m => PropertyT m (Map Int Int) 55 | makeRandomIntMap = do 56 | let genNum = Gen.int (Range.linear 0 100) 57 | length <- forAll genNum 58 | listOfNumbers <- forAll $ Seq.replicateM length genNum 59 | pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers 60 | --------------------------------------------------------------------------------