on develop help sign in
.github/workflows/haskell.ymlnew file+47
since splitsnapshots
unifiedsplit
@@ -0,0 +1,47 @@
1+name: github-action
2+
3+on: [push, pull_request]
4+
5+jobs:
6+ build:
7+ strategy:
8+ matrix:
9+ ghc: ['8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.2']
10+ os: ['ubuntu-latest', 'macos-latest']
11+ exclude:
12+ # There are some linker warnings in 802 on darwin that
13+ # cause compilation to fail
14+ # See https://github.com/NixOS/nixpkgs/issues/25139
15+ - ghc: '8.0.2'
16+ os: 'macos-latest'
17+ runs-on: ${{ matrix.os }}
18+
19+ name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
20+ steps:
21+ - uses: actions/checkout@v2
22+ - uses: actions/setup-haskell@v1
23+ with:
24+ ghc-version: ${{ matrix.ghc }}
25+ - name: Cache
26+ uses: actions/cache@v1
27+ env:
28+ cache-name: cache-cabal
29+ with:
30+ path: ~/.cabal
31+ key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
32+ restore-keys: |
33+ ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
34+ ${{ runner.os }}-${{ matrix.ghc }}-build-
35+ ${{ runner.os }}-${{ matrix.ghc }}-
36+ ${{ runner.os }}
37+
38+ - name: Install dependencies
39+ run: |
40+ cabal update
41+ cabal build --only-dependencies --enable-tests --enable-benchmarks
42+ - name: Build
43+ run: cabal build --enable-tests --enable-benchmarks all
44+ - name: Run tests
45+ run: cabal test --enable-tests all
46+ - name: Build Docs
47+ run: cabal haddock
.travis.ymldeleted−171
@@ -1,171 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.3.20190814
8−#
9−language: c
10−dist: xenial
11−sudo: required
12−git:
13− # whether to recursively clone submodules
14− submodules: false
15−cache:
16− directories:
17− - $HOME/.cabal/packages
18− - $HOME/.cabal/store
19−before_cache:
20− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
21− # remove files that are regenerated by 'cabal update'
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
23− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
27− - rm -rfv $CABALHOME/packages/head.hackage
28−matrix:
29− include:
30− - compiler: ghcjs-8.4
31− addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}
32− - compiler: ghc-8.8.1
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34− - compiler: ghc-8.6.5
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}
36− - compiler: ghc-8.4.4
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}
38− - compiler: ghc-8.2.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}
40− - compiler: ghc-8.0.2
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
42−before_install:
43− - |
44− if [ "$TRAVIS_OS_NAME" = "linux" ]; then
45− sudo add-apt-repository -y ppa:hvr/ghcjs;
46− curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -
47− sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main'
48− sudo apt-get update;
49− sudo apt-get install $CC cabal-install-3.0 nodejs;
50− fi
51− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
52− - WITHCOMPILER="-w $HC"
53− - |
54− if echo $CC | grep -q ghcjs; then
55− GHCJS=true
56− HC=${HC}js
57− WITHCOMPILER="--ghcjs ${WITHCOMPILER}js"
58− else
59− GHCJS=false;
60− fi
61− - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi
62− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
63− - HCPKG="$HC-pkg"
64− - unset CC
65− - CABAL=/opt/ghc/bin/cabal
66− - CABALHOME=$HOME/.cabal
67− - export PATH="$CABALHOME/bin:$PATH"
68− - TOP=$(pwd)
69− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
70− - echo $HCNUMVER
71− - CABAL="$CABAL -vnormal+nowrap+markoutput"
72− - set -o pipefail
73− - |
74− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
75− echo 'BEGIN { state = "output"; }' >> .colorful.awk
76− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
77− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
78− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
79− echo ' if (state == "cabal") {' >> .colorful.awk
80− echo ' print blue($0)' >> .colorful.awk
81− echo ' } else {' >> .colorful.awk
82− echo ' print $0' >> .colorful.awk
83− echo ' }' >> .colorful.awk
84− echo '}' >> .colorful.awk
85− - cat .colorful.awk
86− - |
87− color_cabal_output () {
88− awk -f $TOP/.colorful.awk
89− }
90− - echo text | color_cabal_output
91−install:
92− - ${CABAL} --version
93− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
94− - node --version
95− - echo $GHCJS
96− - TEST=--enable-tests
97− - BENCH=--enable-benchmarks
98− - BENCH=--disable-benchmarks
99− - HEADHACKAGE=false
100− - rm -f $CABALHOME/config
101− - |
102− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
103− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
104− echo "write-ghc-environment-files: always" >> $CABALHOME/config
105− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
106− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
107− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
108− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
109− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
110− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
111− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
112− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
113− echo "install-dirs user" >> $CABALHOME/config
114− echo " prefix: $CABALHOME" >> $CABALHOME/config
115− echo "repository hackage.haskell.org" >> $CABALHOME/config
116− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
117− - cat $CABALHOME/config
118− - rm -fv cabal.project cabal.project.local cabal.project.freeze
119− - travis_retry ${CABAL} v2-update -v
120− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi
121− # Generate cabal.project
122− - rm -rf cabal.project cabal.project.local cabal.project.freeze
123− - touch cabal.project
124− - |
125− echo "packages: ." >> cabal.project
126− - |
127− - cat cabal.project || true
128− - cat cabal.project.local || true
129− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
130− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
131− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
132− - rm cabal.project.freeze
133−script:
134− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
135− # Packaging...
136− - ${CABAL} v2-sdist all | color_cabal_output
137− # Unpacking...
138− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
139− - cd ${DISTDIR} || false
140− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
141− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
142− - PKGDIR_patch="$(find . -maxdepth 1 -type d -regex '.*/patch-[0-9.]*')"
143− # Generate cabal.project
144− - rm -rf cabal.project cabal.project.local cabal.project.freeze
145− - touch cabal.project
146− - |
147− echo "packages: ${PKGDIR_patch}" >> cabal.project
148− - |
149− - cat cabal.project || true
150− - cat cabal.project.local || true
151− # Building...
152− # this builds all libraries and executables (without tests/benchmarks)
153− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
154− # Building with tests and benchmarks...
155− # build & run tests, build benchmarks
156− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
157− # Testing...
158− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
159− # cabal check...
160− - (cd ${PKGDIR_patch} && ${CABAL} -vnormal check)
161− # haddock...
162− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
163− # Constraint sets
164− - rm -rf cabal.project.local
165− # Constraint set old-these
166− - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi
167− # Constraint set old-witherable
168− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output
169−
170−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
171−# EOF
CONTRIBUTING.md+1−1
@@ -16,7 +16,7 @@ Before opening an issue, please check whether your issue has already been report
16* Describe the issue you're encountering or the suggestion you're making
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.
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.
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 patch-platform, cabal install, stack, obelisk, etc.). If you're using patch-platform or obelisk, provide the git hash of your checkout.
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
20
21## Submitting Changes
21## Submitting Changes
22
22
ChangeLog.md+34−6
@@ -2,11 +2,39 @@
2
2
3## Unreleased
3## Unreleased
4
4
5−* `PatchMapWithMove` supports moves with a patch.
5+* New dep of `data-orphans` for old GHC to get instances honestly instead of
6+ via `monoidal-containers`.
6
7
7−* `PatchDMapWithMove` supports moves with a patch.
8+## 0.0.5.0 - 2021-12-17
8
9
9−## 0.0.2.0
10+* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
11+ from `Data.Patch` for compatability.
12+
13+* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
14+ Care is taken to make this not a breaking change.
15+ In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
16+ There are complete constructor and field patterns too, and everything is
17+ exported under the newtype as real constructors and fields would be.
18+
19+## 0.0.4.0 - 2021-04-20
20+
21+* Enable PolyKinds
22+
23+## 0.0.3.2 - 2020-11-06
24+
25+* Update version bounds
26+
27+## 0.0.3.1 - 2020-02-05
28+
29+* Replace `fromJust` with something easier to debug.
30+
31+## 0.0.3.0 - 2020-02-05
32+
33+* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
34+
35+* Create `DecidablyEmpty` subclass of `Monoid`.
36+
37+## 0.0.2.0 - 2020-01-17
10
38
11* Consistently provide:
39* Consistently provide:
12
40
@@ -18,16 +46,16 @@
18
46
19 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
47 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
20
48
21−## 0.0.1.0
49+## 0.0.1.0 - 2020-01-09
22
50
23* Support older GHCs with `split-these` flag.
51* Support older GHCs with `split-these` flag.
24
52
25* Additional instances for the `Group` class for basic types.
53* Additional instances for the `Group` class for basic types.
26
54
27−## 0.0.0.1
55+## 0.0.0.1 - 2020-01-08
28
56
29* Remove unneeded dependencies
57* Remove unneeded dependencies
30
58
31−## 0.0.0.0
59+## 0.0.0.0 - 2020-01-08
32
60
33* Extract patching functionality from Reflex.
61* Extract patching functionality from Reflex.
README.md+6−4
@@ -1,8 +1,10 @@
1−## Patch
1+# patch
2
2
3−Infrastructure for writing patches which act on other types.
3+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/patch.svg)](https://hackage.haskell.org/package/patch) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/patch/badge)](https://matrix.hackage.haskell.org/#/package/patch) [![Travis CI](https://api.travis-ci.org/reflex-frp/patch.svg?branch=develop)](https://travis-ci.org/reflex-frp/patch) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/patch/LICENSE)
4
4
5+Data structures for describing changes to other data structures.
6+
5−A `Patch` type represents a kind of change made to a datastructure.
7+A `Patch` type represents a kind of change made to a data structure.
6
8
7```haskell
9```haskell
8class Patch p where
10class Patch p where
@@ -12,7 +14,7 @@ class Patch p where
12 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
14 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
13```
15```
14
16
15−### Patching Maps
17+## Patching Maps
16For 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).
18For 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).
17
19
18`PatchMap` is defined as:
20`PatchMap` is defined as:
cabal.haskell-cideleted−14
@@ -1,14 +0,0 @@
1−distribution: xenial
2−benchmarks: False
3−unconstrained: False
4−installed: -all
5−
6−-- https://github.com/haskell/cabal/issues/6106
7−install-dependencies: False
8−
9−constraint-set old-these
10− ghc: <8.8
11− constraints: these <1
12−
13−constraint-set old-witherable
14− constraints: witherable <0.3.2
patch.cabal+34−14
@@ -1,7 +1,9 @@
1Name: patch
1Name: patch
2−Version: 0.0.2.0
2+Version: 0.0.5.0
3−Synopsis: Infrastructure for writing patches which act on other types.
3+Synopsis: Data structures for describing changes to other data structures.
4Description:
4Description:
5+ Data structures for describing changes to other data structures.
6+ .
5 In this library, a patch is something which can be applied, analogous to a
7 In this library, a patch is something which can be applied, analogous to a
6 function, and which distinguishes returning the argument it was provided from
8 function, and which distinguishes returning the argument it was provided from
7 returning something else.
9 returning something else.
@@ -12,7 +14,7 @@ Maintainer: maintainer@obsidian.systems
12Stability: Experimental
14Stability: Experimental
13Category: FRP
15Category: FRP
14Build-type: Simple
16Build-type: Simple
15−Cabal-version: >=1.9.2
17+Cabal-version: >=1.10
16homepage: https://obsidian.systems
18homepage: https://obsidian.systems
17bug-reports: https://github.com/reflex-frp/patch/issues
19bug-reports: https://github.com/reflex-frp/patch/issues
18extra-source-files:
20extra-source-files:
@@ -20,7 +22,7 @@ extra-source-files:
20 ChangeLog.md
22 ChangeLog.md
21
23
22tested-with:
24tested-with:
23− GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1
25+ GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1
24 GHCJS ==8.4
26 GHCJS ==8.4
25
27
26flag split-these
28flag split-these
@@ -30,40 +32,58 @@ flag split-these
30
32
31library
33library
32 hs-source-dirs: src
34 hs-source-dirs: src
35+ default-language: Haskell2010
33− build-depends: base >= 4.9 && < 4.14
36+ build-depends: base >= 4.9 && < 4.15
34 , constraints-extras >= 0.3 && < 0.4
37 , constraints-extras >= 0.3 && < 0.4
35 , containers >= 0.6 && < 0.7
38 , containers >= 0.6 && < 0.7
36− , dependent-map >= 0.3 && < 0.4
39+ , dependent-map >= 0.3 && < 0.5
37− , dependent-sum >= 0.6 && < 0.7
40+ , dependent-sum >= 0.6 && < 0.8
38 , lens >= 4.7 && < 5
41 , lens >= 4.7 && < 5
39 , semigroupoids >= 4.0 && < 6
42 , semigroupoids >= 4.0 && < 6
40 , transformers >= 0.5.6.0 && < 0.6
43 , transformers >= 0.5.6.0 && < 0.6
41− , witherable >= 0.3 && < 0.3.2
44+ , witherable >= 0.3 && < 0.5
42
45
43− exposed-modules: Control.Category.DecidablyEmpty
46+ if impl(ghc < 8.6) -- really, if base < 8.12
47+ build-depends: base-orphans >= 0.8 && < 0.9
48+
44− , Data.Functor.Misc
49+ exposed-modules: Data.Functor.Misc
45 , Data.Monoid.DecidablyEmpty
50 , Data.Monoid.DecidablyEmpty
46 , Data.Patch
51 , Data.Patch
47 , Data.Patch.Class
52 , Data.Patch.Class
48 , Data.Patch.DMap
53 , Data.Patch.DMap
49 , Data.Patch.DMapWithMove
54 , Data.Patch.DMapWithMove
50− , Data.Patch.DMapWithMove.By
51 , Data.Patch.IntMap
55 , Data.Patch.IntMap
52 , Data.Patch.Map
56 , Data.Patch.Map
53 , Data.Patch.MapWithMove
57 , Data.Patch.MapWithMove
58+ , Data.Patch.MapWithPatchingMove
59+ , Data.Semigroup.Additive
54
60
55 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
61 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
62+ default-extensions: PolyKinds
56
63
57 if flag(split-these)
64 if flag(split-these)
58− build-depends: these >= 1 && <1.1
65+ build-depends: these >= 1 && <1.2
59− , these-lens >= 1 && <1.1
60 , semialign >=1 && <1.2
66 , semialign >=1 && <1.2
61 , monoidal-containers >= 0.6 && < 0.7
67 , monoidal-containers >= 0.6 && < 0.7
62 else
68 else
63 build-depends: these >= 0.4 && <0.9
69 build-depends: these >= 0.4 && <0.9
64 , monoidal-containers == 0.4.0.0
70 , monoidal-containers == 0.4.0.0
65
71
72+test-suite tests
73+ default-language: Haskell2010
74+ type: exitcode-stdio-1.0
75+ main-is: tests.hs
76+ hs-source-dirs: test
77+ build-depends: base
78+ , patch
79+ , containers
80+ , hedgehog
81+ , HUnit
82+ if impl(ghcjs)
83+ buildable: False
84+
66test-suite hlint
85test-suite hlint
86+ default-language: Haskell2010
67 type: exitcode-stdio-1.0
87 type: exitcode-stdio-1.0
68 main-is: hlint.hs
88 main-is: hlint.hs
69 hs-source-dirs: test
89 hs-source-dirs: test
@@ -71,7 +91,7 @@ test-suite hlint
71 , directory
91 , directory
72 , filepath
92 , filepath
73 , filemanip
93 , filemanip
74− , hlint < 2.1 || >= 2.2.2
94+ , hlint (< 2.1 || >= 2.2.2) && < 3.3
75 if impl(ghcjs)
95 if impl(ghcjs)
76 buildable: False
96 buildable: False
77
97
src/Control/Category/DecidablyEmpty.hsdeleted−9
@@ -1,9 +0,0 @@
1−{-# LANGUAGE TypeOperators #-}
2−-- TODO upstream somwhere else?
3−module Control.Category.DecidablyEmpty where
4−
5−import Control.Category
6−import Data.Type.Equality
7−
8−class Category c => DecidablyEmpty c where
9− isId :: c a b -> Maybe (a :~: b)
src/Data/Functor/Misc.hs+7−31
@@ -1,12 +1,11 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveTraversable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE PatternSynonyms #-}
10{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
@@ -17,8 +16,6 @@
17module Data.Functor.Misc
16module Data.Functor.Misc
18 ( -- * Const2
17 ( -- * Const2
19 Const2 (..)
18 Const2 (..)
20− , Proxy3 (..)
21− , First2 (..)
22 , unConst2
19 , unConst2
23 , dmapToMap
20 , dmapToMap
24 , dmapToIntMap
21 , dmapToIntMap
@@ -39,7 +36,6 @@ module Data.Functor.Misc
39 , ComposeMaybe (..)
36 , ComposeMaybe (..)
40 ) where
37 ) where
41
38
42−import qualified Control.Category as Cat
43import Control.Applicative ((<$>))
39import Control.Applicative ((<$>))
44import Data.Dependent.Map (DMap)
40import Data.Dependent.Map (DMap)
45import qualified Data.Dependent.Map as DMap
41import qualified Data.Dependent.Map as DMap
@@ -51,8 +47,7 @@ import Data.IntMap (IntMap)
51import qualified Data.IntMap as IntMap
47import qualified Data.IntMap as IntMap
52import Data.Map (Map)
48import Data.Map (Map)
53import qualified Data.Map as Map
49import qualified Data.Map as Map
54−import qualified Data.Semigroupoid as Cat
55−import Data.Some (Some(Some))
50+import Data.Some (Some, mkSome)
56import Data.These
51import Data.These
57import Data.Type.Equality ((:~:)(Refl))
52import Data.Type.Equality ((:~:)(Refl))
58import Data.Typeable hiding (Refl)
53import Data.Typeable hiding (Refl)
@@ -67,15 +62,15 @@ data Const2 :: * -> x -> x -> * where
67 Const2 :: k -> Const2 k v v
62 Const2 :: k -> Const2 k v v
68 deriving (Typeable)
63 deriving (Typeable)
69
64
65+-- | Extract the value from a Const2
66+unConst2 :: Const2 k v v' -> k
67+unConst2 (Const2 k) = k
68+
70deriving instance Eq k => Eq (Const2 k v v')
69deriving instance Eq k => Eq (Const2 k v v')
71deriving instance Ord k => Ord (Const2 k v v')
70deriving instance Ord k => Ord (Const2 k v v')
72deriving instance Show k => Show (Const2 k v v')
71deriving instance Show k => Show (Const2 k v v')
73deriving instance Read k => Read (Const2 k v v)
72deriving instance Read k => Read (Const2 k v v)
74
73
75−-- | Extract the value from a Const2
76−unConst2 :: Const2 k v v' -> k
77−unConst2 (Const2 k) = k
78−
79instance Show k => GShow (Const2 k v) where
74instance Show k => GShow (Const2 k v) where
80 gshowsPrec n x@(Const2 _) = showsPrec n x
75 gshowsPrec n x@(Const2 _) = showsPrec n x
81
76
@@ -91,25 +86,6 @@ instance Ord k => GCompare (Const2 k v) where
91 EQ -> GEQ
86 EQ -> GEQ
92 GT -> GGT
87 GT -> GGT
93
88
94−data Proxy3 :: x -> y -> z -> * where
95− Proxy3 :: Proxy3 vx vy vz
96− deriving ( Show, Read, Eq, Ord
97− , Functor, Foldable, Traversable
98− , Typeable
99− )
100−
101−instance Cat.Category (Proxy3 x) where
102− id = Proxy3
103− ~Proxy3 . ~Proxy3 = Proxy3
104−
105−newtype First2 (t :: k -> *) (a :: k) (b :: k) = First2 (t b)
106− deriving ( Show, Read, Eq, Ord
107− , Functor, Foldable, Traversable
108− )
109−
110−instance Cat.Semigroupoid (First2 x) where
111− First2 x `o` ~(First2 _) = First2 x
112−
113-- | Convert a 'DMap' to a regular 'Map'
89-- | Convert a 'DMap' to a regular 'Map'
114dmapToMap :: DMap (Const2 k v) Identity -> Map k v
90dmapToMap :: DMap (Const2 k v) Identity -> Map k v
115dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
91dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
@@ -140,7 +116,7 @@ intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=
140-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
116-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
141-- the keys, using a function to remove the wrapping 'Functor'
117-- the keys, using a function to remove the wrapping 'Functor'
142weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
118weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
143−weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList
119+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (mkSome k, f v)) . DMap.toAscList
144
120
145--------------------------------------------------------------------------------
121--------------------------------------------------------------------------------
146-- WrapArg
122-- WrapArg
src/Data/Monoid/DecidablyEmpty.hs+111−1
@@ -1,5 +1,115 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE StandaloneDeriving #-}
5+{-# LANGUAGE TypeOperators #-}
6+
1-- TODO upstream somwhere else?
7-- TODO upstream somwhere else?
2module Data.Monoid.DecidablyEmpty where
8module Data.Monoid.DecidablyEmpty where
3
9
10+import Data.Functor.Identity
11+import Data.Functor.Const
12+import Data.Monoid
13+import Data.Maybe (isNothing)
14+#if MIN_VERSION_base(4,11,0)
15+import Data.Ord
16+#endif
17+import Data.Proxy
18+import Data.Semigroup hiding (First, Last)
19+#if MIN_VERSION_base(4,12,0)
20+import GHC.Generics
21+#endif
22+
23+import qualified Data.IntSet as IntSet
24+import qualified Data.IntMap as IntMap
25+import qualified Data.Map as Map
26+import qualified Data.Sequence as Seq
27+import qualified Data.Set as Set
28+
29+import Data.GADT.Compare
30+import qualified Data.Dependent.Map as DMap
31+
32+-- | A 'DecidablyEmpty' is one where it can be computed whether or not an
33+-- arbitrary value is 'mempty'.
34+--
35+-- By using this class rather than 'Eq', we avoid unnecessary constraining the
36+-- contents of 'Functor's. This makes it possible to efficiently combine and/or
37+-- nest patch maps with 'Eq'-lacking values (e.g. functions) at the leaves.
4class Monoid a => DecidablyEmpty a where
38class Monoid a => DecidablyEmpty a where
5− isNull :: a -> Bool
39+ isEmpty :: a -> Bool
40+ default isEmpty :: Eq a => a -> Bool
41+ isEmpty = (==) mempty
42+
43+-- base
44+
45+instance DecidablyEmpty Ordering
46+instance DecidablyEmpty ()
47+instance DecidablyEmpty Any
48+instance DecidablyEmpty All
49+-- instance DecidablyEmpty Lifetime
50+-- instance DecidablyEmpty Event
51+instance DecidablyEmpty [a] where
52+ isEmpty = null
53+instance
54+#if MIN_VERSION_base(4,11,0)
55+ Semigroup a
56+#else
57+ Monoid a
58+#endif
59+ => DecidablyEmpty (Maybe a) where
60+ isEmpty = isNothing
61+deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a)
62+deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a)
63+deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a)
64+instance DecidablyEmpty (First a) where
65+ isEmpty (First a) = isNothing a
66+instance DecidablyEmpty (Last a) where
67+ isEmpty (Last a) = isNothing a
68+deriving instance DecidablyEmpty a => DecidablyEmpty (Identity a)
69+instance Semigroup a => DecidablyEmpty (Option a) where
70+ isEmpty (Option a) = isNothing a
71+deriving instance DecidablyEmpty m => DecidablyEmpty (WrappedMonoid m)
72+instance (Ord a, Bounded a) => DecidablyEmpty (Max a)
73+instance (Ord a, Bounded a) => DecidablyEmpty (Min a)
74+instance DecidablyEmpty (Proxy s)
75+deriving instance DecidablyEmpty a => DecidablyEmpty (Const a b)
76+#if MIN_VERSION_base(4,11,0)
77+deriving instance DecidablyEmpty a => DecidablyEmpty (Down a)
78+#endif
79+#if MIN_VERSION_base(4,12,0)
80+deriving instance DecidablyEmpty p => DecidablyEmpty (Par1 p)
81+instance DecidablyEmpty (U1 p)
82+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (Rec1 f p)
83+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (M1 i c f p)
84+deriving instance DecidablyEmpty c => DecidablyEmpty (K1 i c p)
85+instance (DecidablyEmpty (f p), DecidablyEmpty (g p)) => DecidablyEmpty ((f :*: g) p) where
86+ isEmpty (x :*: y) = isEmpty x && isEmpty y
87+deriving instance DecidablyEmpty (f (g p)) => DecidablyEmpty ((f :.: g) p)
88+#endif
89+
90+instance (DecidablyEmpty a, DecidablyEmpty b) => DecidablyEmpty (a, b) where
91+ isEmpty (a, b) = isEmpty a && isEmpty b
92+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c) => DecidablyEmpty (a, b, c) where
93+ isEmpty (a, b, c) = isEmpty a && isEmpty b && isEmpty c
94+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d) => DecidablyEmpty (a, b, c, d) where
95+ isEmpty (a, b, c, d) = isEmpty a && isEmpty b && isEmpty c && isEmpty d
96+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d, DecidablyEmpty e) => DecidablyEmpty (a, b, c, d, e) where
97+ isEmpty (a, b, c, d, e) = isEmpty a && isEmpty b && isEmpty c && isEmpty d && isEmpty e
98+
99+-- containers
100+
101+instance DecidablyEmpty IntSet.IntSet where
102+ isEmpty = IntSet.null
103+instance DecidablyEmpty (IntMap.IntMap v) where
104+ isEmpty = IntMap.null
105+instance Ord k => DecidablyEmpty (Map.Map k v) where
106+ isEmpty = Map.null
107+instance DecidablyEmpty (Seq.Seq v) where
108+ isEmpty = Seq.null
109+instance Ord k => DecidablyEmpty (Set.Set k) where
110+ isEmpty = Set.null
111+
112+-- dependent-map
113+
114+instance GCompare k => DecidablyEmpty (DMap.DMap k v) where
115+ isEmpty = DMap.null
src/Data/Patch.hs+10−23
@@ -18,11 +18,12 @@ import Data.Functor.Const (Const (..))
18import Data.Functor.Identity
18import Data.Functor.Identity
19import Data.Map.Monoidal (MonoidalMap)
19import Data.Map.Monoidal (MonoidalMap)
20import Data.Proxy
20import Data.Proxy
21−#if !MIN_VERSION_base(4,9,0)
21+#if !MIN_VERSION_base(4,11,0)
22−import Data.Semigroup (Semigroup (..), (<>))
22+import Data.Semigroup (Semigroup (..))
23#endif
23#endif
24import GHC.Generics
24import GHC.Generics
25
25
26+import Data.Semigroup.Additive as X
26import Data.Patch.Class as X
27import Data.Patch.Class as X
27import Data.Patch.DMap as X hiding (getDeletions)
28import Data.Patch.DMap as X hiding (getDeletions)
28import Data.Patch.DMapWithMove as X
29import Data.Patch.DMapWithMove as X
@@ -45,34 +46,25 @@ class (Semigroup q, Monoid q) => Group q where
45 (~~) :: q -> q -> q
46 (~~) :: q -> q -> q
46 r ~~ s = r <> negateG s
47 r ~~ s = r <> negateG s
47
48
48−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
49−class Semigroup q => Additive q where
50−
51-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
49-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
52newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
50newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
53
51
54−instance Additive p => PatchHet (AdditivePatch p) where
55− type PatchSource (AdditivePatch p) = p
56− type PatchTarget (AdditivePatch p) = p
57instance Additive p => Patch (AdditivePatch p) where
52instance Additive p => Patch (AdditivePatch p) where
53+ type PatchTarget (AdditivePatch p) = p
58 apply (AdditivePatch p) q = Just $ p <> q
54 apply (AdditivePatch p) q = Just $ p <> q
59
55
60instance (Ord k, Group q) => Group (MonoidalMap k q) where
56instance (Ord k, Group q) => Group (MonoidalMap k q) where
61 negateG = fmap negateG
57 negateG = fmap negateG
62
58
63−instance (Ord k, Additive q) => Additive (MonoidalMap k q)
64−
65-- | Trivial group.
59-- | Trivial group.
66instance Group () where
60instance Group () where
67− negateG ~() = ()
61+ negateG _ = ()
68− ~() ~~ ~() = ()
62+ _ ~~ _ = ()
69−instance Additive ()
70
63
71-- | Product group. A Pair of groups gives rise to a group
64-- | Product group. A Pair of groups gives rise to a group
72instance (Group a, Group b) => Group (a, b) where
65instance (Group a, Group b) => Group (a, b) where
73 negateG (a, b) = (negateG a, negateG b)
66 negateG (a, b) = (negateG a, negateG b)
74 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
67 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
75−instance (Additive a, Additive b) => Additive (a, b)
76
68
77-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
69-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
78-- Base does not define Monoid (Compose f g a) so this is the best we can
70-- Base does not define Monoid (Compose f g a) so this is the best we can
@@ -80,29 +72,24 @@ instance (Additive a, Additive b) => Additive (a, b)
80instance Group (f (g a)) => Group ((f :.: g) a) where
72instance Group (f (g a)) => Group ((f :.: g) a) where
81 negateG (Comp1 xs) = Comp1 (negateG xs)
73 negateG (Comp1 xs) = Comp1 (negateG xs)
82 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
74 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
83−instance Additive (f (g a)) => Additive ((f :.: g) a)
84
75
85-- | Product of groups, Functor style.
76-- | Product of groups, Functor style.
86instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
77instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
87 negateG (a :*: b) = negateG a :*: negateG b
78 negateG (a :*: b) = negateG a :*: negateG b
88 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
79 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
89−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
90
80
91-- | Trivial group, Functor style
81-- | Trivial group, Functor style
92instance Group (Proxy x) where
82instance Group (Proxy x) where
93− negateG ~Proxy = Proxy
83+ negateG _ = Proxy
94− ~Proxy ~~ ~Proxy = Proxy
84+ _ ~~ _ = Proxy
95−instance Additive (Proxy x)
96
85
97-- | Const lifts groups into a functor.
86-- | Const lifts groups into a functor.
98deriving instance Group a => Group (Const a x)
87deriving instance Group a => Group (Const a x)
99−instance Additive a => Additive (Const a x)
88+
100−-- | Ideitnty lifts groups pointwise (at only one point)
89+-- | Identity lifts groups pointwise (at only one point)
101deriving instance Group a => Group (Identity a)
90deriving instance Group a => Group (Identity a)
102−instance Additive a => Additive (Identity a)
103
91
104-- | Functions lift groups pointwise.
92-- | Functions lift groups pointwise.
105instance Group b => Group (a -> b) where
93instance Group b => Group (a -> b) where
106 negateG f = negateG . f
94 negateG f = negateG . f
107 (~~) = liftA2 (~~)
95 (~~) = liftA2 (~~)
108−instance Additive b => Additive (a -> b)
src/Data/Patch/Class.hs+11−132
@@ -1,53 +1,23 @@
1−{-# LANGUAGE DefaultSignatures #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DerivingStrategies #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9-- | The interface for types which represent changes made to other types
4-- | The interface for types which represent changes made to other types
10module Data.Patch.Class where
5module Data.Patch.Class where
11
6
12−import qualified Data.Semigroupoid as Cat
13import Data.Functor.Identity
7import Data.Functor.Identity
14−import Data.Functor.Misc
8+import Data.Kind (Type)
15import Data.Maybe
9import Data.Maybe
10+#if !MIN_VERSION_base(4,11,0)
16import Data.Semigroup (Semigroup(..))
11import Data.Semigroup (Semigroup(..))
12+#endif
17import Data.Proxy
13import Data.Proxy
18−import Data.Type.Equality ((:~:) (..))
19−
20−class PatchHet p where
21− type PatchSource p :: *
22− type PatchTarget p :: *
23− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
24− -- 'Nothing'.
25− applyHet
26− :: p
27− -> PatchSource p
28− -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
29− default applyHet
30− :: Patch p
31− => p
32− -> PatchSource p
33− -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
34− applyHet p a = case apply p a of
35− Nothing -> Left Refl
36− Just a' -> Right a'
37−
38−-- | Apply a 'PatchHet'; if it does nothing, return the original value
39−applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
40−applyAlwaysHet p t = case applyHet p t of
41− Left Refl -> t
42− Right t' -> t'
43
14
44-- | A 'Patch' type represents a kind of change made to a datastructure.
15-- | A 'Patch' type represents a kind of change made to a datastructure.
45--
16--
46-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
17-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
47-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
18-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
48−class ( PatchHet p
49− , PatchSource p ~ PatchTarget p
50− ) => Patch p where
19+class Patch p where
20+ type PatchTarget p :: Type
51 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
21 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
52 -- 'Nothing'.
22 -- 'Nothing'.
53 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
23 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -57,110 +27,19 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
57applyAlways p t = fromMaybe t $ apply p t
27applyAlways p t = fromMaybe t $ apply p t
58
28
59-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
29-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
60−instance PatchHet (Identity a) where
61− type PatchSource (Identity a) = a
62− type PatchTarget (Identity a) = a
63instance Patch (Identity a) where
30instance Patch (Identity a) where
31+ type PatchTarget (Identity a) = a
64 apply (Identity a) _ = Just a
32 apply (Identity a) _ = Just a
65
33
66−-- | 'Proxy' can be used as a 'Patch' that always fully replaces the value
34+-- | 'Proxy' can be used as a 'Patch' that does nothing.
67−instance PatchHet (Proxy (a :: *)) where
35+instance forall (a :: Type). Patch (Proxy a) where
68− type PatchSource (Proxy a) = a
69 type PatchTarget (Proxy a) = a
36 type PatchTarget (Proxy a) = a
70−instance Patch (Proxy (a :: *)) where
71 apply ~Proxy _ = Nothing
37 apply ~Proxy _ = Nothing
72
38
73-- | Like '(.)', but composes functions that return patches rather than
39-- | Like '(.)', but composes functions that return patches rather than
74-- functions that return new values. The Semigroup instance for patches must
40-- functions that return new values. The Semigroup instance for patches must
75-- apply patches right-to-left, like '(.)'.
41-- apply patches right-to-left, like '(.)'.
76−composePatchFunctions
42+composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
77− :: (Patch p, Semigroup p)
78− => (PatchTarget p -> p)
79− -> (PatchTarget p -> p)
80− -> PatchTarget p -> p
81composePatchFunctions g f a =
43composePatchFunctions g f a =
82 let fp = f a
44 let fp = f a
83 in g (applyAlways fp a) <> fp
45 in g (applyAlways fp a) <> fp
84−
85−
86−class PatchHet2Base (p :: k -> k -> *) where
87− type PatchSource1 p :: k -> *
88− type PatchTarget1 p :: k -> *
89−
90−class ( PatchHet2Base p
91− , PatchHet (p from to)
92− , PatchSource1 p from ~ PatchSource (p from to)
93− , PatchTarget1 p to ~ PatchTarget (p from to)
94− ) => PatchHet2Locally (p :: k -> k -> *) from to where
95−instance ( PatchHet2Base p
96− , PatchHet (p from to)
97− , PatchSource1 p from ~ PatchSource (p from to)
98− , PatchTarget1 p to ~ PatchTarget (p from to)
99− ) => PatchHet2Locally (p :: k -> k -> *) from to where
100−
101−applyHet2Locally
102− :: PatchHet2Locally p from to
103− => p from to
104− -> PatchSource1 p from
105− -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
106−applyHet2Locally = applyHet
107−
108−applyAlwaysHet2Locally
109− :: PatchHet2Locally p from to
110− => p from to
111− -> PatchSource1 p from
112− -> PatchTarget1 p to
113−applyAlwaysHet2Locally = applyAlwaysHet
114−
115−-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
116−-- PatchHet2Locally, or at least get rid of this.
117−class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where
118− applyHet2
119− :: p from to
120− -> PatchSource1 p from
121− -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
122−
123−applyAlwaysHet2
124− :: PatchHet2 p
125− => p from to
126− -> PatchSource1 p from
127− -> PatchTarget1 p to
128−applyAlwaysHet2 p t = case applyHet2 p t of
129− Left Refl -> t
130− Right t' -> t'
131−
132−-- | Connect the classes without quanitified constraints
133−newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
134− deriving newtype Cat.Semigroupoid
135−
136−instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
137− type PatchSource (ProjectLocal p from to) = PatchSource1 p from
138− type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
139− applyHet (ProjectLocal p) = applyHet2 p
140−
141−instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
142− type PatchSource1 (ProjectLocal p) = PatchSource1 p
143− type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
144−
145−class ( PatchHet2Base p
146− , PatchSource1 p ~ PatchTarget1 p
147− ) => Patch2 p
148−instance ( PatchHet2Base p
149− , PatchSource1 p ~ PatchTarget1 p
150− ) => Patch2 p
151−
152−-- | 'First2' can be used as a 'Patch' that always fully replaces the value
153−instance PatchHet (First2 (t :: k -> *) (from :: k) (to :: k)) where
154− type PatchSource (First2 t from to) = t from
155− type PatchTarget (First2 t from to) = t to
156− applyHet (First2 val) _ = Right val
157−
158−-- | 'Proxy3' can be used as a 'Patch' that always does nothing
159−instance PatchHet (Proxy3 (t :: k -> *) (a :: k) (a :: k)) where
160− type PatchSource (Proxy3 t a a) = t a
161− type PatchTarget (Proxy3 t a a) = t a
162− applyHet ~Proxy3 _ = Left Refl
163−
164−instance PatchHet2Base (Proxy3 (t :: k -> *) :: k -> k -> *) where
165− type PatchSource1 (Proxy3 t) = t
166− type PatchTarget1 (Proxy3 t) = t
src/Data/Patch/DMap.hs+13−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE PolyKinds #-}
@@ -5,6 +6,7 @@
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9+
8-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
10-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
9module Data.Patch.DMap where
11module Data.Patch.DMap where
10
12
@@ -12,13 +14,18 @@ import Data.Patch.Class
12import Data.Patch.IntMap
14import Data.Patch.IntMap
13import Data.Patch.Map
15import Data.Patch.Map
14
16
15−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
17+import Data.Dependent.Map (DMap)
18+import Data.Dependent.Sum (DSum (..))
19+import Data.GADT.Compare (GCompare (..))
16import qualified Data.Dependent.Map as DMap
20import qualified Data.Dependent.Map as DMap
17import Data.Functor.Constant
21import Data.Functor.Constant
18import Data.Functor.Misc
22import Data.Functor.Misc
19import qualified Data.IntMap as IntMap
23import qualified Data.IntMap as IntMap
20import qualified Data.Map as Map
24import qualified Data.Map as Map
25+import Data.Monoid.DecidablyEmpty
26+#if !MIN_VERSION_base(4,11,0)
21import Data.Semigroup (Semigroup (..))
27import Data.Semigroup (Semigroup (..))
28+#endif
22import Data.Some (Some)
29import Data.Some (Some)
23
30
24-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
31-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
@@ -30,11 +37,13 @@ deriving instance GCompare k => Semigroup (PatchDMap k v)
30
37
31deriving instance GCompare k => Monoid (PatchDMap k v)
38deriving instance GCompare k => Monoid (PatchDMap k v)
32
39
40+-- It won't let me derive for some reason
41+instance GCompare k => DecidablyEmpty (PatchDMap k v) where
42+ isEmpty (PatchDMap m) = DMap.null m
43+
33-- | Apply the insertions or deletions to a given 'DMap'.
44-- | Apply the insertions or deletions to a given 'DMap'.
34−instance GCompare k => PatchHet (PatchDMap k v) where
35− type PatchSource (PatchDMap k v) = DMap k v
36− type PatchTarget (PatchDMap k v) = DMap k v
37instance GCompare k => Patch (PatchDMap k v) where
45instance GCompare k => Patch (PatchDMap k v) where
46+ type PatchTarget (PatchDMap k v) = DMap k v
38 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?
47 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
39 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
48 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
40 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
49 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
src/Data/Patch/DMapWithMove.hs+161−407
@@ -1,222 +1,108 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE InstanceSigs #-}
7{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE PatternGuards #-}
10{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE Rank2Types #-}
9{-# LANGUAGE Rank2Types #-}
12{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
16−{-# LANGUAGE UndecidableSuperClasses #-}
17
13
18-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
19-- move values between keys.
15-- move values between keys.
20module Data.Patch.DMapWithMove where
16module Data.Patch.DMapWithMove where
21
17
22−import qualified Control.Category as Cat
18+import Data.Patch.Class
23−--import qualified Control.Category.DecidablyEmpty as Cat
19+import Data.Patch.MapWithMove (PatchMapWithMove (..))
20+import qualified Data.Patch.MapWithMove as MapWithMove
21+
24−import Data.Constraint.Extras (Has')
22+import Data.Constraint.Extras
25import Data.Dependent.Map (DMap)
23import Data.Dependent.Map (DMap)
26import Data.Dependent.Sum (DSum (..))
24import Data.Dependent.Sum (DSum (..))
27import qualified Data.Dependent.Map as DMap
25import qualified Data.Dependent.Map as DMap
28−import Data.Functor.Constant (Constant (..))
26+import Data.Functor.Constant
29import Data.Functor.Misc
27import Data.Functor.Misc
30− ( Const2 (..), Proxy3 (..)
31− , weakenDMapWith
32− , dmapToMapWith
33− )
34−import Data.Functor.Product (Product (..))
28+import Data.Functor.Product
35import Data.GADT.Compare (GEq (..), GCompare (..))
29import Data.GADT.Compare (GEq (..), GCompare (..))
36−import Data.GADT.Show (GRead, GShow, gshow)
30+import Data.GADT.Show (GShow, gshow)
37import qualified Data.Map as Map
31import qualified Data.Map as Map
38import Data.Maybe
32import Data.Maybe
39−import Data.Semigroup (Semigroup (..), (<>))
33+import Data.Monoid.DecidablyEmpty
40−import Data.Semigroupoid as Cat
34+#if !MIN_VERSION_base(4,11,0)
41−import Data.Some (Some(Some))
42−import Data.Proxy (Proxy (..))
35+import Data.Semigroup (Semigroup (..))
43−import Data.These (These (..))
36+#endif
44−
45−import Data.Patch.Class
37+import Data.Some (Some, mkSome)
46− ( Patch (..), PatchHet (..)
38+import Data.These
47− , PatchHet2 (..), PatchSource1, PatchTarget1
39+
48− , applyAlwaysHet2
49− )
50−import Data.Patch.MapWithMove (PatchMapWithMove (..))
51−import qualified Data.Patch.MapWithMove as MapWithMove
52−
53−-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
54−-- which describes how it will be changed by the patch and connects move sources
40+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
55−-- and destinations.
41+-- destinations.
56--
42--
57-- Invariants:
43-- Invariants:
58--
44--
59−-- * A key should not move to itself.
45+-- * A key should not move to itself.
60−--
61−-- * A move should always be represented with both the destination key (as a
46+-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
62−-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
63−-- destination)@)
64newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
47newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
65
48
66−--deriving instance ( GShow k
49+-- It won't let me derive for some reason
67−-- , HasZip Show k p
68−-- , Has' Show k (PatchTarget1 p)
69−-- ) => Show (PatchDMapWithMove k p)
70−--deriving instance ( GRead k
71−-- , HasZip Read k p
72−-- , Has' Read k (PatchTarget1 p)
73−-- ) => Read (PatchDMapWithMove k p)
74−--deriving instance ( GEq k
75−-- , HasZip Eq k p
76−-- , Has' Eq k (PatchTarget1 p)
77−-- ) => Eq (PatchDMapWithMove k p)
78−--deriving instance ( GCompare k
50+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
79−-- , HasZip Ord k p
51+ isEmpty (PatchDMapWithMove m) = DMap.null m
80−-- , Has' Ord k (PatchTarget1 p)
52+
81−-- ) => Ord (PatchDMapWithMove k p)
82−
83−-- | Structure which represents what changes apply to a particular key.
84−-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
53+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
85−-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
54+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
86−-- key the current key is moving to if involved in a move.
87−data NodeInfo k p a = NodeInfo
55+data NodeInfo k v a = NodeInfo
88− { _nodeInfo_from :: !(From k p a)
56+ { _nodeInfo_from :: !(From k v a)
89− -- ^ Change applying to the current key, be it an insert, move, or delete.
57+ -- ^Change applying to the current key, be it an insert, move, or delete.
90− , _nodeInfo_to :: !(To k p a)
58+ , _nodeInfo_to :: !(To k a)
91− -- ^ Where this key is moving to, if involved in a move. Should only be
59+ -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
92− -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
93 }
60 }
94−
95−--deriving instance ( Show (k a)
61+ deriving (Show)
96−-- , Show (p a a)
62+
97−-- , Show (PatchTarget1 p a)
98−-- ) => Show (NodeInfo k p a)
99−--deriving instance ( Read (k a)
100−-- , Read (p a a)
101−-- , Read (PatchTarget1 p a)
102−-- ) => Read (NodeInfo k p a)
103−--deriving instance ( Eq (k a)
104−-- , Eq (p a a)
105−-- , Eq (PatchTarget1 p a)
106−-- ) => Eq (NodeInfo k p a)
107−--deriving instance ( Ord (k a)
108−-- , Ord (p a a)
109−-- , Ord (PatchTarget1 p a)
110−-- ) => Ord (NodeInfo k p a)
111−
112−-- | Structure describing a particular change to a key, be it inserting a new
63+-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
113−-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
114−-- a key (@From_Delete@), or moving a key (@From_Move@).
64+-- key (@From_Delete@), or moving a key (@From_Move@).
115−--
116−-- This type isn't used directly as the from field patch, but is instead wrapped
117−-- in an existential. However, it is nice to be able to reason about this in
118−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
119−data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
65+data From (k :: a -> *) (v :: a -> *) :: a -> * where
120− -- | Insert a new or update an existing key with the given value @PatchTarget1
66+ -- |Insert a new or update an existing key with the given value @v a@
121− -- p a@
122− From_Insert :: PatchTarget1 p to -> From k p to
67+ From_Insert :: v a -> From k v a
123− -- | Delete the existing key
68+ -- |Delete the existing key
124− From_Delete :: From k p to
69+ From_Delete :: From k v a
125− -- | Move the value from the given key @k a@ to this key. The source key
126− -- should also have an entry in the patch giving the current key as
70+ -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
127− -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
71+ -- usually but not necessarily with @From_Delete@.
128− From_Move :: !(DSum k (Flip p to)) -> From k p to
72+ From_Move :: !(k a) -> From k v a
129−
73+ deriving (Show, Read, Eq, Ord)
130−deriving instance ( Show (k a), GShow k
74+
131− , Has' Show k (Flip p a)
75+-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
132− , Show (PatchTarget1 p a)
76+-- operation.
133− ) => Show (From k p a)
77+type To = ComposeMaybe
134−deriving instance ( Read (k a), GRead k
135− , Has' Read k (Flip p a)
136− , Read (PatchTarget1 p a)
137− ) => Read (From k p a)
138−deriving instance ( GEq k
139− , Has' Eq k (Flip p a)
140− , Eq (PatchTarget1 p a)
141− ) => Eq (From k p a)
142−deriving instance ( GCompare k
143− , Has' Eq k (Flip p a) -- superclass bug
144− , Has' Ord k (Flip p a)
145− , Ord (PatchTarget1 p a)
146− ) => Ord (From k p a)
147−
148−newtype Flip p to from = Flip (p from to)
149−
150−instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
151− id = Flip Cat.id
152− Flip y . Flip x = Flip $ x Cat.. y
153−
154−-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
155−-- is, we store just the information necessary to compose a @To@ and @From@ like
156−-- @oLocal@ composes two @From@s.
157−data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
158− -- | Delete or leave in place
159− To_NonMove :: To k p from
160− -- | Move the value from the given key @k a@ to this key. The target key
161− -- should also have an entry in the patch giving the current key in
162− -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
163− To_Move :: !(DSum k (p from)) -> To k p from
164−
165−deriving instance ( Show (k a), GShow k
166− , Has' Show k (p a)
167− , Show (PatchTarget1 p a)
168− ) => Show (To k p a)
169−deriving instance ( Read (k a), GRead k
170− , Has' Read k (p a)
171− , Read (PatchTarget1 p a)
172− ) => Read (To k p a)
173−deriving instance ( GEq k
174− , Has' Eq k (p a)
175− , Eq (PatchTarget1 p a)
176− ) => Eq (To k p a)
177−deriving instance ( GCompare k
178− , Has' Eq k (p a) -- superclass bug
179− , Has' Ord k (p a)
180− , Ord (PatchTarget1 p a)
181− ) => Ord (To k p a)
182
78
183-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
79-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
184−validPatchDMapWithMove
80+validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
185− :: forall k v
186− . (GCompare k, GShow k)
187− => DMap k (NodeInfo k v)
188− -> Bool
189validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
81validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
190
82
191-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
83-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
192−validationErrorsForPatchDMapWithMove
84+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
193− :: forall k v
194− . (GCompare k, GShow k)
195− => DMap k (NodeInfo k v)
196− -> [String]
197validationErrorsForPatchDMapWithMove m =
85validationErrorsForPatchDMapWithMove m =
198 noSelfMoves <> movesBalanced
86 noSelfMoves <> movesBalanced
199 where
87 where
200 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
88 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
201− selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
202− | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
89+ selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
203− selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
204− | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
90+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
205 selfMove _ = Nothing
91 selfMove _ = Nothing
206 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
92 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
207− unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
93+ unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
208 case DMap.lookup src m of
94 case DMap.lookup src m of
209 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
95 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
210− Just (NodeInfo _ (To_Move (dst' :=> _))) ->
96+ Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
211 if isNothing (dst' `geq` dst)
97 if isNothing (dst' `geq` dst)
212 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
98 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
213 else Nothing
99 else Nothing
214 _ ->
100 _ ->
215 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
101 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
216− unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
102+ unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
217 case DMap.lookup dst m of
103 case DMap.lookup dst m of
218 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
104 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
219− Just (NodeInfo (From_Move (src' :=> _)) _) ->
105+ Just (NodeInfo (From_Move src') _) ->
220 if isNothing (src' `geq` src)
106 if isNothing (src' `geq` src)
221 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
107 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
222 else Nothing
108 else Nothing
@@ -225,49 +111,35 @@ validationErrorsForPatchDMapWithMove m =
225 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
111 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
226 unbalancedMove _ = Nothing
112 unbalancedMove _ = Nothing
227
113
114+-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
115+instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
116+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
117+
228-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
118-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
229data Pair1 f g a = Pair1 (f a) (g a)
119data Pair1 f g a = Pair1 (f a) (g a)
230
120
231-- |Helper data structure used for composing patches using the monoid instance.
121-- |Helper data structure used for composing patches using the monoid instance.
232−data Fixup k p a
122+data Fixup k v a
233 = Fixup_Delete
123 = Fixup_Delete
234− | Fixup_Update (These (From k p a) (To k p a))
124+ | Fixup_Update (These (From k v a) (To k a))
235−
125+
236−-- | Compose patches having the same effect as applying the patches in turn:
126+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
237−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
238−instance ( GCompare k
239− , Cat.Semigroupoid p
240− -- , Cat.DecidablyEmpty p
241− , PatchHet2 p
242− , PatchSource1 p ~ PatchTarget1 p
243− ) => Semigroup (PatchDMapWithMove k p) where
127+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
244 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
128 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
245 where
129 where
246− connections :: [DSum k (Pair1 (To k p) (From k p))]
247− connections = DMap.toList $ DMap.intersectionWithKey
248− (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
130+ connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
249− ma
250− mb
251− h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
131+ h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
252− h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
132+ h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
253− (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
133+ (Just toAfter, From_Move fromBefore)
254− --case toAfter `geq` fromBefore of
134+ | isJust $ fromBefore `geq` toAfter
255− -- Just Refl | Just Refl <- Cat.isId p0 ->
256− -- [ toAfter :=> Fixup_Delete ]
135+ -> [toAfter :=> Fixup_Delete]
257− -- _ ->
136+ | otherwise
258− [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
137+ -> [ toAfter :=> Fixup_Update (This editBefore)
259− , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
138+ , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
260− ]
139+ ]
261− (To_NonMove, From_Move (fromBefore :=> _)) ->
262− -- The item is destroyed in the second patch, so indicate that it is
140+ (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
263− -- destroyed in the source map
264− [fromBefore :=> Fixup_Update (That To_NonMove)]
265− (To_Move (toAfter :=> p), From_Insert val) ->
266− [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
267− (To_Move (toAfter :=> _), From_Delete) ->
268− [toAfter :=> Fixup_Update (This From_Delete)]
141+ (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
269− (To_NonMove, _) ->
142+ (Nothing, _) -> []
270− []
271 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
143 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
272 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
144 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
273 | This x <- a, That y <- b
145 | This x <- a, That y <- b
@@ -298,19 +170,13 @@ instance ( GCompare k
298 These _ b -> Just b
170 These _ b -> Just b
299 That b -> Just b
171 That b -> Just b
300
172
301−-- | Compose patches having the same effect as applying the patches in turn:
173+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
302−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
303−instance ( GCompare k
304− , Cat.Semigroupoid p
305− -- , DecidablyEmpty p
306− , PatchHet2 p
307− , PatchSource1 p ~ PatchTarget1 p
308− ) => Monoid (PatchDMapWithMove k p) where
174+instance GCompare k => Monoid (PatchDMapWithMove k v) where
309 mempty = PatchDMapWithMove mempty
175 mempty = PatchDMapWithMove mempty
310 mappend = (<>)
176 mappend = (<>)
311
177
312{-
178{-
313−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
179+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
314PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
180PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
315 where
181 where
316 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
182 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
@@ -331,51 +197,44 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
331 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
332-}
198-}
333
199
334−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
200+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
335−-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
336−-- 'DMap.insert'.
337−insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
201+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
338insertDMapKey k v =
202insertDMapKey k v =
339− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
203+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
340
204
341−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value
205+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
342−-- from the first key @k a@ to the second key @k a@, equivalent to:
343--
206--
344-- @
207-- @
345-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
208-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
346-- @
209-- @
347−moveDMapKey
348− :: GCompare k
349− => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
210+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
350moveDMapKey src dst = case src `geq` dst of
211moveDMapKey src dst = case src `geq` dst of
351 Nothing -> PatchDMapWithMove $ DMap.fromList
212 Nothing -> PatchDMapWithMove $ DMap.fromList
352− [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
213+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
353− , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
214+ , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
354 ]
215 ]
355− Just _ -> PatchDMapWithMove DMap.empty
216+ Just _ -> mempty
356
217
357−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
218+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
358−-- in the mapping, equivalent to:
359--
219--
360-- @
220-- @
361-- let aMay = DMap.lookup a dmap
221-- let aMay = DMap.lookup a dmap
362-- bMay = DMap.lookup b dmap
222-- bMay = DMap.lookup b dmap
363−-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
223+-- in maybe id (DMap.insert a) (bMay <> aMay)
364−-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
224+-- . maybe id (DMap.insert b) (aMay <> bMay)
365-- . DMap.delete a . DMap.delete b $ dmap
225-- . DMap.delete a . DMap.delete b $ dmap
366-- @
226-- @
367−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
227+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
368swapDMapKey src dst = case src `geq` dst of
228swapDMapKey src dst = case src `geq` dst of
369 Nothing -> PatchDMapWithMove $ DMap.fromList
229 Nothing -> PatchDMapWithMove $ DMap.fromList
370− [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
230+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
371− , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
231+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
372 ]
232 ]
373− Just _ -> PatchDMapWithMove DMap.empty
233+ Just _ -> mempty
374
234
375−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
235+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
376−-- the mapping, equivalent to 'DMap.delete'.
377deleteDMapKey :: k a -> PatchDMapWithMove k v
236deleteDMapKey :: k a -> PatchDMapWithMove k v
378−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
237+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
379
238
380{-
239{-
381k1, k2 :: Const2 Int () ()
240k1, k2 :: Const2 Int () ()
@@ -401,20 +260,17 @@ dst (PatchDMapWithMove x _) = x
401src (PatchDMapWithMove _ x) = x
260src (PatchDMapWithMove _ x) = x
402-}
261-}
403
262
404−-- | Extract the 'DMap' representing the patch changes from the
263+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
405−-- 'PatchDMapWithMove'.
406unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
264unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
407unPatchDMapWithMove (PatchDMapWithMove p) = p
265unPatchDMapWithMove (PatchDMapWithMove p) = p
408
266
409−-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
267+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
410−-- without checking any invariants.
411--
268--
412-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
269-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
413unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
270unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
414unsafePatchDMapWithMove = PatchDMapWithMove
271unsafePatchDMapWithMove = PatchDMapWithMove
415
272
416−-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while
417−-- checking invariants. If the invariants are satisfied, @Right p@ is returned
273+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
418-- otherwise @Left errors@.
274-- otherwise @Left errors@.
419patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
275patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
420patchDMapWithMove dm =
276patchDMapWithMove dm =
@@ -422,196 +278,94 @@ patchDMapWithMove dm =
422 [] -> Right $ unsafePatchDMapWithMove dm
278 [] -> Right $ unsafePatchDMapWithMove dm
423 errs -> Left errs
279 errs -> Left errs
424
280
425−-- | Map a natural transform @v -> v'@ over the given patch, transforming
281+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
426−-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
427−mapPatchDMapWithMove
282+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
428− :: forall k p p'
429− . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
430− -> (forall from to. p from to -> p' from to)
431− -> PatchDMapWithMove k p
432− -> PatchDMapWithMove k p'
433−mapPatchDMapWithMove f g (PatchDMapWithMove m) =
283+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
434− PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
435− { _nodeInfo_from = h $ _nodeInfo_from ni
284+ DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
436− , _nodeInfo_to = j $ _nodeInfo_to ni
437− }) m
438− where h :: forall a. From k p a -> From k p' a
285+ where g :: forall a. From k v a -> From k v' a
439− h = \case
286+ g = \case
440 From_Insert v -> From_Insert $ f v
287 From_Insert v -> From_Insert $ f v
441 From_Delete -> From_Delete
288 From_Delete -> From_Delete
442− From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
289+ From_Move k -> From_Move k
443− j :: forall a. To k p a -> To k p' a
290+
444− j = \case
445− To_NonMove -> To_NonMove
446− To_Move (k :=> p) -> To_Move $ k :=> g p
447−
448−-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
449−-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
291+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
450−-- ('PatchDMapWithMove' k v')@.
451−traversePatchDMapWithMove
292+traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
452− :: forall m k p p'
453− . Applicative m
454− => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
455− -> (forall from to. p from to -> m (p' from to))
456− -> PatchDMapWithMove k p
457− -> m (PatchDMapWithMove k p')
458−traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
293+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
459− (\_ -> f)
294+
460− (\_ _ -> g)
461−
462−-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
463−-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
295+-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
464−-- ('PatchDMapWithMove' k v')@.
465−traversePatchDMapWithMoveWithKey
296+traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
466− :: forall m k p p'
467− . Applicative m
468− => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
469− -> (forall from to. k from -> k to -> p from to -> m (p' from to))
470− -> PatchDMapWithMove k p
471− -> m (PatchDMapWithMove k p')
472−traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
297+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
473− PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
474− <$> h k (_nodeInfo_from ni)
475− <*> j k (_nodeInfo_to ni)) m
476− where h :: forall a. k a -> From k p a -> m (From k p' a)
298+ where g :: forall a. k a -> From k v a -> m (From k v' a)
477− h k = \case
299+ g k = \case
478 From_Insert v -> From_Insert <$> f k v
300 From_Insert v -> From_Insert <$> f k v
479 From_Delete -> pure From_Delete
301 From_Delete -> pure From_Delete
480− From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
302+ From_Move fromKey -> pure $ From_Move fromKey
481− j :: forall a. k a -> To k p a -> m (To k p' a)
303+
482− j k = \case
483− To_NonMove -> pure To_NonMove
484− To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
485−
486−-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
304+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
487−-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
488−nodeInfoMapFrom
305+nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
489− :: (From k p a -> From k p' a)
490− -> (To k p a -> To k p' a)
491− -> NodeInfo k p a
492− -> NodeInfo k p' a
493−nodeInfoMapFrom f g ni = NodeInfo
494− { _nodeInfo_from = f $ _nodeInfo_from ni
306+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
495− , _nodeInfo_to = g $ _nodeInfo_to ni
307+
496− }
497−
498−-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
308+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
499−-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
500−nodeInfoMapFromM
309+nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
501− :: Applicative f
310+nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
502− => (From k p a -> f (From k p' a))
311+
503− -> (To k p a -> f (To k p' a))
504− -> NodeInfo k p a
505− -> f (NodeInfo k p' a)
506−nodeInfoMapFromM f g ni = NodeInfo
507− <$> f (_nodeInfo_from ni)
508− <*> g (_nodeInfo_to ni)
509−
510−-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
312+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
511−-- from @k a@ to @'Some' k@ and applying a given weakening function
512−-- @PatchTarget1 p a -> v'@ to values.
313+-- values.
513−weakenPatchDMapWithMoveWith
314+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
514− :: forall k p p'
515− . (forall a. PatchTarget1 p a -> PatchTarget p')
516− -> (forall from to. p from to -> p')
517− -> PatchDMapWithMove k p
518− -> PatchMapWithMove (Some k) p'
519−weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
315+weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
520− PatchMapWithMove $ weakenDMapWith h m
521− where h :: forall a. NodeInfo k p a -> MapWithMove.NodeInfo (Some k) p'
316+ where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
522− h ni = MapWithMove.NodeInfo
317+ g ni = MapWithMove.NodeInfo
523 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
524 From_Insert v -> MapWithMove.From_Insert $ f v
319 From_Insert v -> MapWithMove.From_Insert $ f v
525 From_Delete -> MapWithMove.From_Delete
320 From_Delete -> MapWithMove.From_Delete
526− From_Move (k :=> Flip p) -> MapWithMove.From_Move (Some k) $ g p
321+ From_Move k -> MapWithMove.From_Move $ mkSome k
527− , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
322+ , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
528− To_NonMove -> MapWithMove.To_NonMove
529− To_Move (k :=> p) -> MapWithMove.To_Move (Some k) $ g p
530 }
323 }
531
324
532−-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
533−-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
325+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
534−-- dependency in the typing and all points are already @a@, hence the function
326+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
535−-- to map each value to @v'@ is not higher rank.
536−patchDMapWithMoveToPatchMapWithMoveWith
327+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
537− :: forall k p p' a
538− . (PatchTarget1 p a -> PatchTarget p')
539− -> (p a a -> p')
540− -> PatchDMapWithMove (Const2 k a) p
541− -> PatchMapWithMove k p'
542−patchDMapWithMoveToPatchMapWithMoveWith f g (PatchDMapWithMove m) =
328+patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
543− PatchMapWithMove $ dmapToMapWith h m
544− where h :: NodeInfo (Const2 k a) p a -> MapWithMove.NodeInfo k p'
329+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
545− h ni = MapWithMove.NodeInfo
330+ g ni = MapWithMove.NodeInfo
546 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
331 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
547 From_Insert v -> MapWithMove.From_Insert $ f v
332 From_Insert v -> MapWithMove.From_Insert $ f v
548 From_Delete -> MapWithMove.From_Delete
333 From_Delete -> MapWithMove.From_Delete
549− From_Move (Const2 k :=> Flip p) -> MapWithMove.From_Move k $ g p
334+ From_Move (Const2 k) -> MapWithMove.From_Move k
550− , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
335+ , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
551− To_NonMove -> MapWithMove.To_NonMove
552− To_Move (Const2 k :=> p) -> MapWithMove.To_Move k $ g p
553 }
336 }
554
337
555−-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
338+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
556−-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
557−-- dependently typed one but which always has a constant key type represented by
339+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
558−-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
559−-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
340+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
560−const2PatchDMapWithMoveWith
341+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
561− :: forall k v v' a
562− . (v -> v' a)
563− -> PatchMapWithMove k (Proxy v)
564− -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
565−const2PatchDMapWithMoveWith f (PatchMapWithMove p) =
566− PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
342+const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
567− where g :: (k, MapWithMove.NodeInfo k (Proxy v))
568− -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
343+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
569 g (k, ni) = Const2 k :=> NodeInfo
344 g (k, ni) = Const2 k :=> NodeInfo
570 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
345 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
571 MapWithMove.From_Insert v -> From_Insert $ f v
346 MapWithMove.From_Insert v -> From_Insert $ f v
572 MapWithMove.From_Delete -> From_Delete
347 MapWithMove.From_Delete -> From_Delete
573− MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
348+ MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
574− , _nodeInfo_to = case MapWithMove._nodeInfo_to ni of
349+ , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
575− MapWithMove.To_NonMove -> To_NonMove
576− MapWithMove.To_Move toKey Proxy -> To_Move $ Const2 toKey :=> Proxy3
577 }
350 }
578
351
579-- | Apply the insertions, deletions, and moves to a given 'DMap'.
352-- | Apply the insertions, deletions, and moves to a given 'DMap'.
580−instance ( GCompare k
581− , PatchHet2 p
582− , PatchSource1 p ~ PatchTarget1 p
583− ) => PatchHet (PatchDMapWithMove k p) where
584− type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
585− type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
586−
587−instance ( GCompare k
588− , PatchHet2 p
589− , PatchSource1 p ~ PatchTarget1 p
590− ) => Patch (PatchDMapWithMove k p) where
353+instance GCompare k => Patch (PatchDMapWithMove k v) where
354+ type PatchTarget (PatchDMapWithMove k v) = DMap k v
591− apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
355+ apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
592− -- TODO: return Nothing sometimes --Note: the strict application here is
593− -- critical to ensuring that incremental merges don't hold onto all their
594− -- prerequisite events forever; can we make this more robust?
595− where insertions = DMap.mapMaybeWithKey insertFunc m
356+ where insertions = DMap.mapMaybeWithKey insertFunc p
596− insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
357+ insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
597 insertFunc _ ni = case _nodeInfo_from ni of
358 insertFunc _ ni = case _nodeInfo_from ni of
598 From_Insert v -> Just v
359 From_Insert v -> Just v
599− From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
360+ From_Move k -> DMap.lookup k old
600 From_Delete -> Nothing
361 From_Delete -> Nothing
601− deletions = DMap.mapMaybeWithKey deleteFunc m
362+ deletions = DMap.mapMaybeWithKey deleteFunc p
602− deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
363+ deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
603 deleteFunc _ ni = case _nodeInfo_from ni of
364 deleteFunc _ ni = case _nodeInfo_from ni of
604 From_Delete -> Just $ Constant ()
365 From_Delete -> Just $ Constant ()
605 _ -> Nothing
366 _ -> Nothing
606
367
607−-- | Get the values that will be replaced, deleted, or moved if the given patch
368+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
608−-- is applied to the given 'DMap'.
609−getDeletionsAndMoves
369+getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
610− :: ( GCompare k
611− , PatchSource1 p ~ PatchTarget1 p
612− )
613− => PatchDMapWithMove k p
614− -> DMap k (PatchSource1 p)
615− -> DMap k (Product (PatchTarget1 p) (To k p))
616getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
617 where f _ v ni = Pair v $ _nodeInfo_to ni
371 where f _ v ni = Pair v $ _nodeInfo_to ni
src/Data/Patch/DMapWithMove/By.hsdeleted−89
@@ -1,89 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE Rank2Types #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE StandaloneDeriving #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−{-# LANGUAGE UndecidableSuperClasses #-}
16−
17−module Data.Patch.DMapWithMove.By where
18−
19−import Data.Semigroupoid as Cat
20−
21−import Data.Patch.Class
22−
23−-- | Structure describing a particular change to a key, be it inserting a new
24−-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
25−-- a key (@By_Delete@), or moving a key (@By_Move@).
26−--
27−-- This type isn't used directly as the from field patch, but is instead wrapped
28−-- in an existential. However, it is nice to be able to reason about this in
29−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
30−data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
31− -- | Insert a new or update an existing key with the given value @PatchTarget1
32− -- p a@
33− By_Insert :: PatchTarget1 p to -> By k p from to
34− -- | Delete the existing key
35− By_Delete :: By k p from to
36− -- | Move the value from the given key @k a@ to this key. The source key
37− -- should also have an entry in the patch giving the current key as
38− -- @_nodeInfo_to@, usually but not necessarily with @By_Delete@.
39− By_Move :: !(k from) -> p from to -> By k p from to
40−
41−deriving instance ( Show (k from), Show (k to)
42− , Show (p from to)
43− , Show (PatchTarget1 p to)
44− ) => Show (By k p from to)
45−deriving instance ( Read (k from), Read (k to)
46− , Read (p from to)
47− , Read (PatchTarget1 p to)
48− ) => Read (By k p from to)
49−deriving instance ( Eq (k from), Eq (k to)
50− , Eq (p from to)
51− , Eq (PatchTarget1 p to)
52− ) => Eq (By k p from to)
53−deriving instance ( Ord (k from), Ord (k to)
54− , Ord (p from to)
55− , Ord (PatchTarget1 p to)
56− ) => Ord (By k p from to)
57−
58−mapByPatch
59− :: PatchTarget1 p0 ~ PatchTarget1 p1
60− => (p0 from to -> p1 from to)
61− -> By k p0 from to
62− -> By k p1 from to
63−mapByPatch f = \case
64− By_Insert v -> By_Insert v
65− By_Delete -> By_Delete
66− By_Move k p -> By_Move k $ f p
67−
68−-- | Compose patches having the same effect as applying the patches in turn:
69−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
70−instance ( PatchSource1 p ~ PatchTarget1 p
71− , Cat.Semigroupoid p
72− , PatchHet2 p
73− ) => Cat.Semigroupoid (By k p) where
74− o p0 p1 = mapByPatch unProjectLocal $
75− oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
76−
77−oLocal
78− :: ( PatchSource1 p ~ PatchTarget1 p
79− , PatchHet2Locally p between after
80− , Cat.Semigroupoid p
81− )
82− => By k p between after
83− -> By k p before between
84− -> By k p before after
85−By_Insert new `oLocal` _ = By_Insert new
86−By_Delete `oLocal` _ = By_Delete
87−By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2Locally x y
88−By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
89−By_Move _ _ `oLocal` By_Delete = By_Delete
src/Data/Patch/IntMap.hs+11−10
@@ -1,7 +1,9 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE TemplateHaskell #-}
7{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
7
9
@@ -13,7 +15,10 @@ import Control.Lens
13import Data.IntMap.Strict (IntMap)
15import Data.IntMap.Strict (IntMap)
14import qualified Data.IntMap.Strict as IntMap
16import qualified Data.IntMap.Strict as IntMap
15import Data.Maybe
17import Data.Maybe
16−import Data.Semigroup
18+import Data.Monoid.DecidablyEmpty
19+#if !MIN_VERSION_base(4,11,0)
20+import Data.Semigroup (Semigroup (..))
21+#endif
17import Data.Patch.Class
22import Data.Patch.Class
18
23
19-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
24-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
@@ -21,24 +26,20 @@ import Data.Patch.Class
21-- and @Nothing@ means delete.
26-- and @Nothing@ means delete.
22newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }
27newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }
23 deriving ( Show, Read, Eq, Ord
28 deriving ( Show, Read, Eq, Ord
24− , Functor, Foldable, Traversable, Monoid
29+ , Functor, Foldable, Traversable
30+ , Monoid, DecidablyEmpty
25 )
31 )
26
32
27-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
33-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
28-- If the same key is modified by both patches, the one on the left will take
34-- If the same key is modified by both patches, the one on the left will take
29-- precedence.
35-- precedence.
30−instance Semigroup (PatchIntMap v) where
36+deriving instance Semigroup (PatchIntMap v)
31− PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
32− -- PatchMap is idempotent, so stimes n is id for every n
33− stimes = stimesIdempotentMonoid
34
37
35makeWrapped ''PatchIntMap
38makeWrapped ''PatchIntMap
36
39
37-- | Apply the insertions or deletions to a given 'IntMap'.
40-- | Apply the insertions or deletions to a given 'IntMap'.
38−instance PatchHet (PatchIntMap a) where
39− type PatchSource (PatchIntMap a) = IntMap a
40− type PatchTarget (PatchIntMap a) = IntMap a
41instance Patch (PatchIntMap a) where
41instance Patch (PatchIntMap a) where
42+ type PatchTarget (PatchIntMap a) = IntMap a
42 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
43 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
43 let removes = IntMap.filter isNothing p
44 let removes = IntMap.filter isNothing p
44 adds = IntMap.mapMaybe id p
45 adds = IntMap.mapMaybe id p
@@ -58,7 +59,7 @@ mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k m
58-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@
59-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@
59-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
60-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
60traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
61traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
61−traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
62+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (traverse . f) m
62
63
63-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
64-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
64patchIntMapNewElements :: PatchIntMap a -> [a]
65patchIntMapNewElements :: PatchIntMap a -> [a]
src/Data/Patch/Map.hs+10−11
@@ -1,5 +1,7 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE StandaloneDeriving #-}
@@ -16,7 +18,8 @@ import Control.Lens
16import Data.Map (Map)
18import Data.Map (Map)
17import qualified Data.Map as Map
19import qualified Data.Map as Map
18import Data.Maybe
20import Data.Maybe
19−import Data.Semigroup
21+import Data.Monoid.DecidablyEmpty
22+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
20
23
21-- | A set of changes to a 'Map'. Any element may be inserted/updated or
24-- | A set of changes to a 'Map'. Any element may be inserted/updated or
22-- deleted. Insertions are represented as values wrapped in 'Just', while
25-- deleted. Insertions are represented as values wrapped in 'Just', while
@@ -24,11 +27,14 @@ import Data.Semigroup
24newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
27newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
25 deriving ( Show, Read, Eq, Ord
28 deriving ( Show, Read, Eq, Ord
26 , Foldable, Traversable
29 , Foldable, Traversable
30+ , DecidablyEmpty
27 )
31 )
28
32
29-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
33-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
30-- Deletions are unaffected.
34-- Deletions are unaffected.
31deriving instance Functor (PatchMap k)
35deriving instance Functor (PatchMap k)
36+-- | The empty 'PatchMap' contains no insertions or deletions
37+deriving instance Ord k => Monoid (PatchMap k v)
32
38
33-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
39-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
34-- If the same key is modified by both patches, the one on the left will take
40-- If the same key is modified by both patches, the one on the left will take
@@ -38,13 +44,9 @@ instance Ord k => Semigroup (PatchMap k v) where
38 -- PatchMap is idempotent, so stimes n is id for every n
44 -- PatchMap is idempotent, so stimes n is id for every n
39 stimes = stimesIdempotentMonoid
45 stimes = stimesIdempotentMonoid
40
46
41−makeWrapped ''PatchMap
42−
43-- | Apply the insertions or deletions to a given 'Map'.
47-- | Apply the insertions or deletions to a given 'Map'.
44−instance Ord k => PatchHet (PatchMap k v) where
45− type PatchSource (PatchMap k v) = Map k v
46− type PatchTarget (PatchMap k v) = Map k v
47instance Ord k => Patch (PatchMap k v) where
48instance Ord k => Patch (PatchMap k v) where
49+ type PatchTarget (PatchMap k v) = Map k v
48 {-# INLINABLE apply #-}
50 {-# INLINABLE apply #-}
49 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?
51 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
50 where insertions = Map.mapMaybeWithKey (const id) p
52 where insertions = Map.mapMaybeWithKey (const id) p
@@ -59,11 +61,6 @@ instance TraversableWithIndex k (PatchMap k) where
59 itraverse = itraversed . Indexed
61 itraverse = itraversed . Indexed
60 itraversed = _Wrapped .> itraversed <. traversed
62 itraversed = _Wrapped .> itraversed <. traversed
61
63
62−-- | The empty 'PatchMap' contains no insertions or deletions
63−instance Ord k => Monoid (PatchMap k v) where
64− mempty = PatchMap mempty
65− mappend = (<>)
66−
67-- | Returns all the new elements that will be added to the 'Map'
64-- | Returns all the new elements that will be added to the 'Map'
68patchMapNewElements :: PatchMap k v -> [v]
65patchMapNewElements :: PatchMap k v -> [v]
69patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
66patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
@@ -71,3 +68,5 @@ patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
71-- | Returns all the new elements that will be added to the 'Map'
68-- | Returns all the new elements that will be added to the 'Map'
72patchMapNewElementsMap :: PatchMap k v -> Map k v
69patchMapNewElementsMap :: PatchMap k v -> Map k v
73patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
70patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
71+
72+makeWrapped ''PatchMap
src/Data/Patch/MapWithMove.hs+234−287
@@ -2,364 +2,311 @@
2{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PatternGuards #-}
9+{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE StandaloneDeriving #-}
11{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE ViewPatterns #-}
14
16
15-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
17-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
16-- another
18-- another
17−module Data.Patch.MapWithMove where
19+module Data.Patch.MapWithMove
20+ ( PatchMapWithMove
21+ ( PatchMapWithMove
22+ , unPatchMapWithMove
23+ , ..
24+ )
25+ , patchMapWithMove
26+ , patchMapWithMoveInsertAll
27+ , insertMapKey
28+ , moveMapKey
29+ , swapMapKey
30+ , deleteMapKey
31+ , unsafePatchMapWithMove
32+ , patchMapWithMoveNewElements
33+ , patchMapWithMoveNewElementsMap
34+ , patchThatSortsMapWith
35+ , patchThatChangesAndSortsMapWith
36+ , patchThatChangesMap
18
37
38+ -- * Node Info
39+ , NodeInfo
40+ ( NodeInfo
41+ , _nodeInfo_to
42+ , _nodeInfo_from
43+ , ..
44+ )
45+ , bitraverseNodeInfo
46+ , nodeInfoMapFrom
47+ , nodeInfoMapMFrom
48+ , nodeInfoSetTo
49+
50+ -- * From
51+ , From
52+ ( From_Insert
53+ , From_Delete
54+ , From_Move
55+ , ..
56+ )
57+ , bitraverseFrom
58+
59+ -- * To
60+ , To
61+ ) where
62+
63+import Data.Coerce
64+import Data.Kind (Type)
19import Data.Patch.Class
65import Data.Patch.Class
66+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
20
68
21−import Control.Arrow
69+import Control.Lens
22−import Control.Lens hiding (from, to)
23−import Control.Monad.Trans.State
24−import Data.Foldable
25−import Data.Function
26import Data.List
70import Data.List
27import Data.Map (Map)
71import Data.Map (Map)
28import qualified Data.Map as Map
72import qualified Data.Map as Map
29−import Data.Maybe
73+import Data.Proxy
30−--import Data.Proxy
31−#if !MIN_VERSION_base(4,9,0)
74+#if !MIN_VERSION_base(4,11,0)
32−import Data.Semigroup (Semigroup (..), (<>))
75+import Data.Semigroup (Semigroup (..))
33#endif
76#endif
34−import Data.Monoid.DecidablyEmpty
77+import Data.Traversable (foldMapDefault)
35−import qualified Data.Set as Set
36−import Data.These (These (..))
37−import Data.Tuple
38
78
39-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
79-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
40-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
80-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
41-- and vice versa. There should never be any unpaired From/To keys.
81-- and vice versa. There should never be any unpaired From/To keys.
42−newtype PatchMapWithMove k p = PatchMapWithMove
82+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
43− { -- | Extract the internal representation of the 'PatchMapWithMove'
83+ { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
44− unPatchMapWithMove :: Map k (NodeInfo k p)
84+ unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
45 }
85 }
46−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)
86+ deriving ( Show, Read, Eq, Ord
47−deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithMove k p)
87+-- Haddock cannot handle documentation here before GHC 8.6
48−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
88+ ,
49−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
89+#if __GLASGOW_HASKELL__ >= 806
90+ -- | Compose patches having the same effect as applying the
91+ -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92+ -- 'applyAlways' q@
93+#endif
94+ Semigroup
95+ , Monoid
96+ )
50
97
51−-- -- | Skips the patch so it's 'Functor' and friends
98+pattern Coerce :: Coercible a b => a -> b
52−-- newtype PatchMapWithMove' k v = PatchMapWithMove' { unPatchMapWithMove' :: PatchMapWithMove k (Proxy v) }
99+pattern Coerce x <- (coerce -> x)
53−--
100+ where Coerce x = coerce x
54−-- deriving instance Functor (PatchMapWithMove' k)
55−-- deriving instance Foldable (PatchMapWithMove' k)
56−-- deriving instance Traversable (PatchMapWithMove' k)
57
101
58−-- | Holds the information about each key: where its new value should come from,
102+{-# COMPLETE PatchMapWithMove #-}
59−-- and where its old value should go to
103+pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
60−data NodeInfo k p = NodeInfo
104+-- | Extract the representation of the 'PatchMapWithMove' as a map of
61− { _nodeInfo_from :: !(From k p)
105+-- 'NodeInfo'.
62− -- ^ Where do we get the new value for this key?
106+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
63− , _nodeInfo_to :: !(To k p)
107+pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
64− -- ^ If the old value is being kept (i.e. moved rather than deleted or
65− -- replaced), where is it going?
66− }
67−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
68−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
69−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
70−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
71
108
72−-- | Describe how a key's new value should be produced
109+_PatchMapWithMove
73−data From k p
110+ :: Iso
74− = From_Insert (PatchTarget p) -- ^ Insert the given value here
111+ (PatchMapWithMove k0 v0)
75− | From_Delete -- ^ Delete the existing value, if any, from here
112+ (PatchMapWithMove k1 v1)
76− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
113+ (Map k0 (NodeInfo k0 v0))
77−
114+ (Map k1 (NodeInfo k1 v1))
78−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
115+_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
79−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
80−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
81−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
82−
83−-- | Describe where a key's old value will go. If this is 'Just', that means
84−-- the key's old value will be moved to the given other key; if it is 'Nothing',
85−-- that means it will be deleted.
86−data To k p
87− = To_NonMove
88− | To_Move !k !p
89− deriving ( Show, Read, Eq, Ord
90− , Functor, Foldable, Traversable
91− )
92
116
93−makeWrapped ''PatchMapWithMove
117+instance Functor (PatchMapWithMove k) where
118+ fmap f = runIdentity . traverse (Identity . f)
119+
94−--makeWrapped ''PatchMapWithMove'
120+instance Foldable (PatchMapWithMove k) where
121+ foldMap = foldMapDefault
95
122
123+instance Traversable (PatchMapWithMove k) where
124+ traverse =
125+ _PatchMapWithMove .
126+ traverse .
127+ traverse
128+
96−-- instance FunctorWithIndex k (PatchMapWithMove k)
129+instance FunctorWithIndex k (PatchMapWithMove k)
97−-- instance FoldableWithIndex k (PatchMapWithMove k)
130+instance FoldableWithIndex k (PatchMapWithMove k)
98−-- instance TraversableWithIndex k (PatchMapWithMove k) where
131+instance TraversableWithIndex k (PatchMapWithMove k) where
99−-- itraverse = itraversed . Indexed
132+ itraverse = itraversed . Indexed
100−-- itraversed = _Wrapped .> itraversed <. traversed
133+ itraversed =
134+ _PatchMapWithMove .>
135+ itraversed <.
136+ traverse
101
137
102-- | Create a 'PatchMapWithMove', validating it
138-- | Create a 'PatchMapWithMove', validating it
103−patchMapWithMove
104− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
139+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
105−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
106− where valid = forwardLinks == backwardLinks
107− forwardLinks = flip Map.mapMaybe m $ \x -> case _nodeInfo_to x of
108− To_NonMove -> Nothing
109− To_Move to _ -> Just to
110− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
111− case _nodeInfo_from p of
112− From_Move from _ -> Just (from, to)
113− _ -> Nothing
114
141
115-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
116−patchMapWithMoveInsertAll
143+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
117− :: Map k (PatchTarget p) -> PatchMapWithMove k p
118−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
144+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
119− { _nodeInfo_from = From_Insert v
120− , _nodeInfo_to = To_NonMove
121− }
122
145
123−-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
146+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
124−insertMapKey
125− :: k -> PatchTarget p -> PatchMapWithMove k p
147+insertMapKey :: k -> v -> PatchMapWithMove k v
126−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) To_NonMove
148+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
127
149
128−-- |Make a @'PatchMapWithMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
150+-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
129--
151--
130-- @
152-- @
131-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
153-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
132-- @
154-- @
133−moveMapKey
134− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
155+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
135−moveMapKey src dst
156+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
136− | src == dst = mempty
157+
137− | otherwise =
138− PatchMapWithMove $ Map.fromList
139− [ (dst, NodeInfo (From_Move src mempty) To_NonMove)
140− , (src, NodeInfo From_Delete (To_Move dst mempty))
141− ]
142−
143−-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
158+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
144--
159--
145-- @
160-- @
146-- let aMay = Map.lookup a map
161-- let aMay = Map.lookup a map
147-- bMay = Map.lookup b map
162-- bMay = Map.lookup b map
148−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
163+-- in maybe id (Map.insert a) (bMay <> aMay)
149−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
164+-- . maybe id (Map.insert b) (aMay <> bMay)
150-- . Map.delete a . Map.delete b $ map
165-- . Map.delete a . Map.delete b $ map
151-- @
166-- @
152−swapMapKey
153− :: (DecidablyEmpty p, Patch p)
154− => Ord k => k -> k -> PatchMapWithMove k p
167+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
155−swapMapKey src dst
168+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
156− | src == dst = mempty
169+
157− | otherwise =
158− PatchMapWithMove $ Map.fromList
159− [ (dst, NodeInfo (From_Move src mempty) (To_Move dst mempty))
160− , (src, NodeInfo (From_Move dst mempty) (To_Move dst mempty))
161− ]
162−
163−-- | Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in
170+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
164−-- the mapping, equivalent to 'Map.delete'.
165−deleteMapKey
166− :: k -> PatchMapWithMove k v
171+deleteMapKey :: k -> PatchMapWithMove k v
167−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete To_NonMove
172+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
168
173
169-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
174-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
170--
175--
171-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
176-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
172−unsafePatchMapWithMove
173− :: Map k (NodeInfo k p) -> PatchMapWithMove k p
177+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
174−unsafePatchMapWithMove = PatchMapWithMove
178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
175
179
176-- | Apply the insertions, deletions, and moves to a given 'Map'
180-- | Apply the insertions, deletions, and moves to a given 'Map'
177−instance (Ord k, Patch p) => PatchHet (PatchMapWithMove k p) where
181+instance Ord k => Patch (PatchMapWithMove k v) where
178− type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)
182+ type PatchTarget (PatchMapWithMove k v) = Map k v
179− type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
183+ apply (PatchMapWithMove' p) = apply p
180−
184+
181−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
182− -- TODO: return Nothing sometimes
183− -- Note: the strict application here is critical to ensuring that incremental
184− -- merges don't hold onto all their prerequisite events forever; can we make
185− -- this more robust?
186− apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
187− where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
188− From_Insert v -> Just v
189− From_Move k p -> applyAlways p <$> Map.lookup k old
190− From_Delete -> Nothing
191− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
192− From_Delete -> Just ()
193− _ -> Nothing
194−
195−-- | Returns all the new elements that will be added to the 'Map'
185+-- | Returns all the new elements that will be added to the 'Map'.
196−patchMapWithMoveNewElements
186+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
197− :: PatchMapWithMove k p -> [PatchTarget p]
187+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
198−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
199
188
200-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
189-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
201−patchMapWithMoveNewElementsMap
190+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
202− :: PatchMapWithMove k p -> Map k (PatchTarget p)
203−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
191+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
204− where f ni = case _nodeInfo_from ni of
205− From_Insert v -> Just v
206− From_Move _ _ -> Nothing
207− From_Delete -> Nothing
208
192
209-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
193-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
210-- its values using the given ordering function. The set keys of the 'Map' is
194-- its values using the given ordering function. The set keys of the 'Map' is
211-- not changed.
195-- not changed.
212−patchThatSortsMapWith
196+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
213− :: (Ord k, Monoid p)
214− => (PatchTarget p -> PatchTarget p -> Ordering)
215− -> Map k (PatchTarget p) -> PatchMapWithMove k p
216−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
197+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
217− where unsorted = Map.toList m
218− sorted = sortBy (cmp `on` snd) unsorted
219− f (to, _) (from, _) = if to == from then Nothing else
220− Just (from, to)
221− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
222− g (to, _) (from, _) = if to == from then Nothing else
223− let Just movingTo = Map.lookup from reverseMapping
224− in Just (to, NodeInfo (From_Move from mempty) $ To_Move movingTo mempty)
225
198
226-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
227-- will produce a 'Map' with the same values as the second 'Map' but with the
200-- will produce a 'Map' with the same values as the second 'Map' but with the
228-- values sorted with the given ordering function.
201-- values sorted with the given ordering function.
229−patchThatChangesAndSortsMapWith
202+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
230− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
231− => (PatchTarget p -> PatchTarget p -> Ordering)
232− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
233patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
234 where newList = Map.toList newByIndexUnsorted
204 where newList = Map.toList newByIndexUnsorted
235 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
236
206
237-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
207-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
238-- will produce the second 'Map'.
208-- will produce the second 'Map'.
239−patchThatChangesMap
209+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
240− :: (Ord k, Ord (PatchTarget p), Monoid p)
241− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
242−patchThatChangesMap oldByIndex newByIndex = patch
210+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
243− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
211+ PM.patchThatChangesMap oldByIndex newByIndex
244− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
212+
245− let f k v = do
213+--
246− remainingValues <- get
214+-- NodeInfo
247− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
215+--
248− then Map.delete v remainingValues
216+
249− else Map.insert v remainingKeys remainingValues
217+-- | Holds the information about each key: where its new value should come from,
250− case Map.lookup v remainingValues of
218+-- and where its old value should go to
251− Nothing -> return $ NodeInfo (From_Insert v) $ To_Move undefined undefined -- There's no existing value we can take
219+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
252− Just fromKs ->
220+
253− if k `Set.member` fromKs
221+deriving instance (Show k, Show p) => Show (NodeInfo k p)
254− then do
222+deriving instance (Read k, Read p) => Read (NodeInfo k p)
255− putRemainingKeys $ Set.delete k fromKs
223+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
256− return $ NodeInfo (From_Move k mempty) $ To_Move undefined undefined -- There's an existing value, and it's here, so no patch necessary
224+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
257− else do
225+
258− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
226+{-# COMPLETE NodeInfo #-}
259− putRemainingKeys remainingKeys
227+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
260− return $ NodeInfo (From_Move fromK mempty) $ To_Move undefined undefined
228+_nodeInfo_to :: NodeInfo k v -> To k
261− Map.traverseWithKey f newByIndex
229+_nodeInfo_from :: NodeInfo k v -> From k v
262− unusedOldKeys = fold unusedValuesByValue
230+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
263− pointlessMove k = \case
231+ PM.NodeInfo
264− From_Move k' _ | k == k' -> True
232+ { PM._nodeInfo_to = _nodeInfo_to
265− _ -> False
233+ , PM._nodeInfo_from = Coerce _nodeInfo_from
266− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
234+ }
267− then To_Move undefined undefined
235+
268− else To_NonMove
236+_NodeInfo
269− patch = unsafePatchMapWithMove $ Map.filterWithKey
237+ :: Iso
270− (\k -> not . pointlessMove k . _nodeInfo_from)
238+ (NodeInfo k0 v0)
271− $ Map.mergeWithKey
239+ (NodeInfo k1 v1)
272− (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a)
240+ (PM.NodeInfo k0 (Proxy v0))
273− (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k)
241+ (PM.NodeInfo k1 (Proxy v1))
274− (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k)
242+_NodeInfo = iso unNodeInfo' NodeInfo'
275− insertsAndMoves
243+
276− oldByIndex
244+instance Functor (NodeInfo k) where
245+ fmap f = runIdentity . traverse (Identity . f)
246+
247+instance Foldable (NodeInfo k) where
248+ foldMap = foldMapDefault
249+
250+instance Traversable (NodeInfo k) where
251+ traverse = bitraverseNodeInfo pure
252+
253+bitraverseNodeInfo
254+ :: Applicative f
255+ => (k0 -> f k1)
256+ -> (v0 -> f v1)
257+ -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258+bitraverseNodeInfo fk fv = fmap NodeInfo'
259+ . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260+ . coerce
277
261
278-- | Change the 'From' value of a 'NodeInfo'
262-- | Change the 'From' value of a 'NodeInfo'
279−nodeInfoMapFrom
280− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
263+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
281−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
282
265
283-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
284-- 'Applicative', 'Monad', etc.) action to get the new value
267-- 'Applicative', 'Monad', etc.) action to get the new value
285nodeInfoMapMFrom
268nodeInfoMapMFrom
269+ :: Functor f
270+ => (From k v -> f (From k v))
286− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
271+ -> NodeInfo k v -> f (NodeInfo k v)
287−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
272+nodeInfoMapMFrom f = fmap NodeInfo'
273+ . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274+ . coerce
288
275
289-- | Set the 'To' field of a 'NodeInfo'
276-- | Set the 'To' field of a 'NodeInfo'
290−nodeInfoSetTo
291− :: To k p -> NodeInfo k p -> NodeInfo k p
277+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
292−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
278+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
293−
279+
294−-- | Helper data structure used for composing patches using the monoid instance.
280+--
295−data Fixup k p
281+-- From
296− = Fixup_Delete
282+--
297− | Fixup_Update (These (From k p) (To k p))
283+
298−
284+-- | Describe how a key's new value should be produced
299−-- | Compose patches having the same effect as applying the patches in turn:
285+newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
300−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
286+
301−instance ( Ord k
287+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
302− , DecidablyEmpty p
288+
303− , Patch p
289+-- | Insert the given value here
304− ) => Semigroup (PatchMapWithMove k p) where
290+pattern From_Insert :: v -> From k v
305− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
291+pattern From_Insert v = From' (PM.From_Insert v)
306− where
292+
307− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
293+-- | Delete the existing value, if any, from here
308− h :: (k, (To k p, From k p)) -> [(k, Fixup k p)]
294+pattern From_Delete :: From k v
309− h (_, (editAfter, editBefore)) = case (editAfter, editBefore) of
295+pattern From_Delete = From' PM.From_Delete
310− (To_Move toAfter p1, From_Move fromBefore p0)
296+
311− | fromBefore == toAfter && isNull p0
297+-- | Move the value here from the given key
312− -> [(toAfter, Fixup_Delete)]
298+pattern From_Move :: k -> From k v
313− | otherwise
299+pattern From_Move k = From' (PM.From_Move k Proxy)
314− -> [ (toAfter, Fixup_Update (This $ From_Move fromBefore $ p1 <> p0))
300+
315− , (fromBefore, Fixup_Update (That $ To_Move toAfter $ p1 <> p0))
301+bitraverseFrom
316− ]
302+ :: Applicative f
317− (To_NonMove, From_Move fromBefore _) ->
303+ => (k0 -> f k1)
318− -- The item is destroyed in the second patch, so indicate that it is
304+ -> (v0 -> f v1)
319− -- destroyed in the source map
305+ -> From k0 v0 -> f (From k1 v1)
320− [(fromBefore, Fixup_Update (That editAfter))]
306+bitraverseFrom fk fv = fmap From'
321− (To_Move toAfter p, From_Insert val) ->
307+ . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
322− [(toAfter, Fixup_Update $ This $ From_Insert $ applyAlways p val)]
308+ . coerce
323− (To_Move toAfter _, From_Delete) ->
309+
324− [(toAfter, Fixup_Update $ This From_Delete)]
310+makeWrapped ''PatchMapWithMove
325− (To_NonMove, _) -> []
311+makeWrapped ''NodeInfo
326− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
312+makeWrapped ''From
327− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
328− | This x <- a, That y <- b
329− = Fixup_Update $ These x y
330− | That y <- a, This x <- b
331− = Fixup_Update $ These x y
332− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
333− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
334− combineNodeInfos _ nia nib = NodeInfo
335− { _nodeInfo_from = _nodeInfo_from nia
336− , _nodeInfo_to = _nodeInfo_to nib
337− }
338− applyFixup _ ni = \case
339− Fixup_Delete -> Nothing
340− Fixup_Update u -> Just $ NodeInfo
341− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
342− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
343− }
344− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
345− getHere :: These a b -> Maybe a
346− getHere = \case
347− This a -> Just a
348− These a _ -> Just a
349− That _ -> Nothing
350− getThere :: These a b -> Maybe b
351− getThere = \case
352− This _ -> Nothing
353− These _ b -> Just b
354− That b -> Just b
355−
356−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
357−-- | Compose patches having the same effect as applying the patches in turn:
358−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
359−instance ( Ord k
360− , Monoid p
361− , DecidablyEmpty p
362− , Patch p
363− ) => Monoid (PatchMapWithMove k p) where
364− mempty = PatchMapWithMove mempty
365− mappend = (<>)
src/Data/Patch/MapWithPatchingMove.hsnew file+432
@@ -0,0 +1,432 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15+-- another
16+module Data.Patch.MapWithPatchingMove
17+ ( PatchMapWithPatchingMove (..)
18+ , patchMapWithPatchingMove
19+ , patchMapWithPatchingMoveInsertAll
20+ , insertMapKey
21+ , moveMapKey
22+ , swapMapKey
23+ , deleteMapKey
24+ , unsafePatchMapWithPatchingMove
25+ , patchMapWithPatchingMoveNewElements
26+ , patchMapWithPatchingMoveNewElementsMap
27+ , patchThatSortsMapWith
28+ , patchThatChangesAndSortsMapWith
29+ , patchThatChangesMap
30+
31+ -- * Node Info
32+ , NodeInfo (..)
33+ , bitraverseNodeInfo
34+ , nodeInfoMapFrom
35+ , nodeInfoMapMFrom
36+ , nodeInfoSetTo
37+
38+ -- * From
39+ , From(..)
40+ , bitraverseFrom
41+
42+ -- * To
43+ , To
44+
45+ -- TODO internals module
46+ , Fixup (..)
47+ ) where
48+
49+import Data.Patch.Class
50+
51+import Control.Lens hiding (from, to)
52+import Control.Lens.TH (makeWrapped)
53+import Data.Align (align)
54+import Data.Foldable (toList)
55+import Data.Function
56+import Data.List
57+import Data.Map (Map)
58+import qualified Data.Map as Map
59+import Data.Maybe
60+#if !MIN_VERSION_base(4,11,0)
61+import Data.Semigroup (Semigroup (..))
62+#endif
63+import Data.Monoid.DecidablyEmpty
64+import Data.Set (Set)
65+import qualified Data.Set as Set
66+import Data.These (These (..))
67+
68+-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
69+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
70+-- and vice versa. There should never be any unpaired From/To keys.
71+newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
72+ { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
73+ unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
74+ }
75+
76+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
77+deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
78+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
79+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
80+
81+deriving instance ( Ord k
82+#if !MIN_VERSION_base(4,11,0)
83+ , Semigroup p
84+#endif
85+ , DecidablyEmpty p
86+ , Patch p
87+ ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
88+
89+-- | Create a 'PatchMapWithPatchingMove', validating it
90+patchMapWithPatchingMove
91+ :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
92+patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
93+ where valid = forwardLinks == backwardLinks
94+ forwardLinks = Map.mapMaybe _nodeInfo_to m
95+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
96+ case _nodeInfo_from p of
97+ From_Move from _ -> Just (from, to)
98+ _ -> Nothing
99+
100+-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
101+patchMapWithPatchingMoveInsertAll
102+ :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
103+patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
104+ { _nodeInfo_from = From_Insert v
105+ , _nodeInfo_to = Nothing
106+ }
107+
108+-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
109+insertMapKey
110+ :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
111+insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
112+
113+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
114+--
115+-- @
116+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
117+-- @
118+moveMapKey
119+ :: ( DecidablyEmpty p
120+#if !MIN_VERSION_base(4,11,0)
121+ , Semigroup p
122+#endif
123+ , Patch p
124+ )
125+ => Ord k => k -> k -> PatchMapWithPatchingMove k p
126+moveMapKey src dst
127+ | src == dst = mempty
128+ | otherwise =
129+ PatchMapWithPatchingMove $ Map.fromList
130+ [ (dst, NodeInfo (From_Move src mempty) Nothing)
131+ , (src, NodeInfo From_Delete (Just dst))
132+ ]
133+
134+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
135+--
136+-- @
137+-- let aMay = Map.lookup a map
138+-- bMay = Map.lookup b map
139+-- in maybe id (Map.insert a) (bMay <> aMay)
140+-- . maybe id (Map.insert b) (aMay <> bMay)
141+-- . Map.delete a . Map.delete b $ map
142+-- @
143+swapMapKey
144+ :: ( DecidablyEmpty p
145+#if !MIN_VERSION_base(4,11,0)
146+ , Semigroup p
147+#endif
148+ , Patch p
149+ )
150+ => Ord k => k -> k -> PatchMapWithPatchingMove k p
151+swapMapKey src dst
152+ | src == dst = mempty
153+ | otherwise =
154+ PatchMapWithPatchingMove $ Map.fromList
155+ [ (dst, NodeInfo (From_Move src mempty) (Just src))
156+ , (src, NodeInfo (From_Move dst mempty) (Just dst))
157+ ]
158+
159+-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
160+-- the mapping, equivalent to 'Map.delete'.
161+deleteMapKey
162+ :: k -> PatchMapWithPatchingMove k v
163+deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
164+
165+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
166+--
167+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
168+unsafePatchMapWithPatchingMove
169+ :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
170+unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
171+
172+-- | Apply the insertions, deletions, and moves to a given 'Map'
173+instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
174+ type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
175+ -- TODO: return Nothing sometimes
176+ -- Note: the strict application here is critical to ensuring that incremental
177+ -- merges don't hold onto all their prerequisite events forever; can we make
178+ -- this more robust?
179+ apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
180+ where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
181+ From_Insert v -> Just v
182+ From_Move k p -> applyAlways p <$> Map.lookup k old
183+ From_Delete -> Nothing
184+ deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
185+ From_Delete -> Just ()
186+ _ -> Nothing
187+
188+-- | Returns all the new elements that will be added to the 'Map'
189+patchMapWithPatchingMoveNewElements
190+ :: PatchMapWithPatchingMove k p -> [PatchTarget p]
191+patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
192+
193+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
194+patchMapWithPatchingMoveNewElementsMap
195+ :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
196+patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
197+ where f ni = case _nodeInfo_from ni of
198+ From_Insert v -> Just v
199+ From_Move _ _ -> Nothing
200+ From_Delete -> Nothing
201+
202+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
203+-- its values using the given ordering function. The set keys of the 'Map' is
204+-- not changed.
205+patchThatSortsMapWith
206+ :: (Ord k, Monoid p)
207+ => (PatchTarget p -> PatchTarget p -> Ordering)
208+ -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
209+patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
210+ where unsorted = Map.toList m
211+ sorted = sortBy (cmp `on` snd) unsorted
212+ f (to, _) (from, _) = if to == from then Nothing else
213+ Just (from, to)
214+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
215+ g (to, _) (from, _) = if to == from then Nothing else
216+ let Just movingTo = Map.lookup from reverseMapping
217+ in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
218+
219+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
220+-- will produce a 'Map' with the same values as the second 'Map' but with the
221+-- values sorted with the given ordering function.
222+patchThatChangesAndSortsMapWith
223+ :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
224+ => (PatchTarget p -> PatchTarget p -> Ordering)
225+ -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
226+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
227+ where newList = Map.toList newByIndexUnsorted
228+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
229+
230+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231+-- will produce the second 'Map'.
232+-- Note: this will never produce a patch on a value.
233+patchThatChangesMap
234+ :: forall k p
235+ . (Ord k, Ord (PatchTarget p), Monoid p)
236+ => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237+patchThatChangesMap oldByIndex newByIndex = patch
238+ where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
239+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
240+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
241+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
242+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
243+ unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
244+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
245+ -- Generate patch info for a single value
246+ -- Keys that are found in both the old and new sets will not be patched
247+ -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
248+ -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
249+ patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
250+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
251+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
252+ That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
253+ These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
254+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
255+ patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
256+ patchSingleValueThese v = \case
257+ This oldKeys -> patchSingleValue v oldKeys mempty
258+ That newKeys -> patchSingleValue v mempty newKeys
259+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
260+ -- Generate froms and tos for all values, then merge them together
261+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
262+ patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
263+ This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
264+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
265+ These from to -> NodeInfo from to
266+
267+--
268+-- NodeInfo
269+--
270+
271+-- | Holds the information about each key: where its new value should come from,
272+-- and where its old value should go to
273+data NodeInfo k p = NodeInfo
274+ { _nodeInfo_from :: !(From k p)
275+ -- ^ Where do we get the new value for this key?
276+ , _nodeInfo_to :: !(To k)
277+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
278+ -- replaced), where is it going?
279+ }
280+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
281+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
284+
285+-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of
286+-- the type families here, this doesn't it any bi- or tri-traversal class.
287+bitraverseNodeInfo
288+ :: Applicative f
289+ => (k0 -> f k1)
290+ -> (p0 -> f p1)
291+ -> (PatchTarget p0 -> f (PatchTarget p1))
292+ -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
293+bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
294+ <$> bitraverseFrom fk fp fpt from
295+ <*> traverse fk to
296+
297+-- | Change the 'From' value of a 'NodeInfo'
298+nodeInfoMapFrom
299+ :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
300+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
301+
302+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
303+-- 'Applicative', 'Monad', etc.) action to get the new value
304+nodeInfoMapMFrom
305+ :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
306+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
307+
308+-- | Set the 'To' field of a 'NodeInfo'
309+nodeInfoSetTo
310+ :: To k -> NodeInfo k v -> NodeInfo k v
311+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
312+
313+--
314+-- From
315+--
316+
317+-- | Describe how a key's new value should be produced
318+data From k p
319+ = From_Insert (PatchTarget p) -- ^ Insert the given value here
320+ | From_Delete -- ^ Delete the existing value, if any, from here
321+ | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
322+
323+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
324+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
327+
328+-- | Traverse the 'From' over the key, patch, and patch target. Because of
329+-- the type families here, this doesn't it any bi- or tri-traversal class.
330+bitraverseFrom
331+ :: Applicative f
332+ => (k0 -> f k1)
333+ -> (p0 -> f p1)
334+ -> (PatchTarget p0 -> f (PatchTarget p1))
335+ -> From k0 p0 -> f (From k1 p1)
336+bitraverseFrom fk fp fpt = \case
337+ From_Insert pt -> From_Insert <$> fpt pt
338+ From_Delete -> pure From_Delete
339+ From_Move k p -> From_Move <$> fk k <*> fp p
340+
341+--
342+-- To
343+--
344+
345+-- | Describe where a key's old value will go. If this is 'Just', that means
346+-- the key's old value will be moved to the given other key; if it is 'Nothing',
347+-- that means it will be deleted.
348+type To = Maybe
349+
350+--
351+-- Fixup
352+--
353+
354+-- | Helper data structure used for composing patches using the monoid instance.
355+data Fixup k v
356+ = Fixup_Delete
357+ | Fixup_Update (These (From k v) (To k))
358+
359+-- | Compose patches having the same effect as applying the patches in turn:
360+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
361+instance ( Ord k
362+#if !MIN_VERSION_base(4,11,0)
363+ , Semigroup p
364+#endif
365+ , DecidablyEmpty p
366+ , Patch p
367+ ) => Semigroup (PatchMapWithPatchingMove k p) where
368+ PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
369+ where
370+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
371+ h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
372+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
373+ (Just toAfter, From_Move fromBefore p)
374+ | fromBefore == toAfter && isEmpty p
375+ -> [(toAfter, Fixup_Delete)]
376+ | otherwise
377+ -> [ (toAfter, Fixup_Update (This editBefore))
378+ , (fromBefore, Fixup_Update (That mToAfter))
379+ ]
380+ (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
381+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
382+ (Nothing, _) -> []
383+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
384+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
385+ | This x <- a, That y <- b
386+ = Fixup_Update $ These x y
387+ | That y <- a, This x <- b
388+ = Fixup_Update $ These x y
389+ mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
390+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
391+ combineNodeInfos _ nia nib = NodeInfo
392+ { _nodeInfo_from = _nodeInfo_from nia
393+ , _nodeInfo_to = _nodeInfo_to nib
394+ }
395+ applyFixup _ ni = \case
396+ Fixup_Delete -> Nothing
397+ Fixup_Update u -> Just $ NodeInfo
398+ { _nodeInfo_from = case _nodeInfo_from ni of
399+ f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
400+ Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
401+ Just (From_Insert v) -> From_Insert $ applyAlways p' v
402+ Just From_Delete -> From_Delete
403+ Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
404+ _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
405+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
406+ }
407+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
408+ getHere :: These a b -> Maybe a
409+ getHere = \case
410+ This a -> Just a
411+ These a _ -> Just a
412+ That _ -> Nothing
413+ getThere :: These a b -> Maybe b
414+ getThere = \case
415+ This _ -> Nothing
416+ These _ b -> Just b
417+ That b -> Just b
418+
419+--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
420+-- | Compose patches having the same effect as applying the patches in turn:
421+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
422+instance ( Ord k
423+#if !MIN_VERSION_base(4,11,0)
424+ , Semigroup p
425+#endif
426+ , DecidablyEmpty p
427+ , Patch p
428+ ) => Monoid (PatchMapWithPatchingMove k p) where
429+ mempty = PatchMapWithPatchingMove mempty
430+ mappend = (<>)
431+
432+makeWrapped ''PatchMapWithPatchingMove
src/Data/Semigroup/Additive.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE TypeFamilies #-}
4+-- |
5+-- Module:
6+-- Data.Semigroup.Additive
7+-- Description:
8+-- This module defines a class for commutative semigroups, until it is moved
9+-- to another library.
10+module Data.Semigroup.Additive
11+ ( Additive
12+ ) where
13+
14+import Data.Functor.Const (Const (..))
15+import Data.Functor.Identity
16+import Data.Proxy
17+#if !MIN_VERSION_base(4,12,0)
18+-- for :*: and :.: semigroup instances
19+import Data.Orphans ()
20+#endif
21+#if !MIN_VERSION_base(4,11,0)
22+import Data.Semigroup (Semigroup (..))
23+#endif
24+import GHC.Generics
25+
26+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
27+class Semigroup q => Additive q where
28+
29+-- | Trivial additive semigroup.
30+instance Additive ()
31+
32+-- | Product additive semigroup.
33+-- A Pair of additive semigroups gives rise to a additive semigroup
34+instance (Additive a, Additive b) => Additive (a, b)
35+
36+-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
37+-- Base does not define Monoid (Compose f g a) so this is the best we can
38+-- really do for functor composition.
39+instance Additive (f (g a)) => Additive ((f :.: g) a)
40+
41+-- | Product of additive semigroups, Functor style.
42+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
43+
44+-- | Trivial additive semigroup, Functor style
45+instance Additive (Proxy x)
46+
47+-- | Const lifts additive semigroups into a functor.
48+instance Additive a => Additive (Const a x)
49+
50+-- | Identity lifts additive semigroups pointwise (at only one point)
51+instance Additive a => Additive (Identity a)
52+
53+-- | Functions lift additive semigroups pointwise.
54+instance Additive b => Additive (a -> b)
test/hlint.hs+2−1
@@ -1,7 +1,7 @@
1module Main where
1module Main where
2
2
3import Control.Monad
3import Control.Monad
4−import Language.Haskell.HLint3 (hlint)
4+import Language.Haskell.HLint (hlint)
5import System.Directory
5import System.Directory
6import System.Exit (exitFailure, exitSuccess)
6import System.Exit (exitFailure, exitSuccess)
7import System.FilePath
7import System.FilePath
@@ -23,6 +23,7 @@ main = do
23 , "--ignore=Reduce duplication"
23 , "--ignore=Reduce duplication"
24 , "--cpp-define=USE_TEMPLATE_HASKELL"
24 , "--cpp-define=USE_TEMPLATE_HASKELL"
25 , "--ignore=Use tuple-section"
25 , "--ignore=Use tuple-section"
26+ , "--ignore=Unused LANGUAGE pragma" -- hlint3 falsely believes that TypeOperators is not needed
26 ]
27 ]
27 recurseInto = and <$> sequence
28 recurseInto = and <$> sequence
28 [ fileType ==? Directory
29 [ fileType ==? Directory
test/tests.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+module Main where
3+
4+import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)
5+import Data.Patch ( Patch(apply) )
6+import Data.Patch.MapWithMove ( patchThatChangesMap )
7+import Data.Map as Map ( Map, fromList, singleton )
8+import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))
9+import Hedgehog.Gen as Gen ( int )
10+import Hedgehog.Range as Range ( linear )
11+import Control.Monad (replicateM)
12+import System.Exit (exitFailure, exitSuccess)
13+import Data.Sequence as Seq ( foldMapWithIndex, replicateM )
14+
15+main :: IO ()
16+main = do
17+ counts <- runTestTT $ test [
18+ "Simple Move" ~: (do
19+ let mapBefore = Map.fromList [(0,1)]
20+ mapAfter = Map.fromList [(0,0),(1,1)]
21+ patch = patchThatChangesMap mapBefore mapAfter
22+ afterPatch = apply patch mapBefore
23+ assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),
24+ "Property Checks" ~: propertyChecks
25+ ]
26+ if errors counts + failures counts == 0 then exitSuccess else exitFailure
27+
28+propertyChecks :: IO Bool
29+propertyChecks = checkParallel $$(discover)
30+
31+prop_patchThatChangesMap :: Property
32+prop_patchThatChangesMap = property $ do
33+ mapBefore <- makeRandomIntMap
34+ mapAfter <- makeRandomIntMap
35+ let patch = patchThatChangesMap mapBefore mapAfter
36+ Just mapAfter === apply patch mapBefore
37+
38+makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)
39+makeRandomIntMap = do
40+ let genNum = Gen.int (Range.linear 0 100)
41+ length <- forAll genNum
42+ listOfNumbers <- forAll $ Seq.replicateM length genNum
43+ pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers