git.iko.soy/patch
on develop help sign in
swap
b6af86973 ahead, 0 behind
.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+33−5
@@ -1,12 +1,40 @@
1# Revision history for patch
1# Revision history for patch
2
2
3−## 0.0.3.0
3+## Unreleased
4+
5+* New dep of `data-orphans` for old GHC to get instances honestly instead of
6+ via `monoidal-containers`.
7+
8+## 0.0.5.0 - 2021-12-17
9+
10+* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
11+ from `Data.Patch` for compatability.
12+
13+* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
14+ Care is taken to make this not a breaking change.
15+ In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
16+ There are complete constructor and field patterns too, and everything is
17+ exported under the newtype as real constructors and fields would be.
18+
19+## 0.0.4.0 - 2021-04-20
20+
21+* Enable PolyKinds
22+
23+## 0.0.3.2 - 2020-11-06
24+
25+* Update version bounds
26+
27+## 0.0.3.1 - 2020-02-05
28+
29+* Replace `fromJust` with something easier to debug.
30+
31+## 0.0.3.0 - 2020-02-05
4
32
5* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
33* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
6
34
7* Create `DecidablyEmpty` subclass of `Monoid`.
35* Create `DecidablyEmpty` subclass of `Monoid`.
8
36
9−## 0.0.2.0
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+32−10
@@ -1,7 +1,9 @@
1Name: patch
1Name: patch
2−Version: 0.0.3.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,15 +32,19 @@ 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
45+
46+ if impl(ghc < 8.6) -- really, if base < 8.12
47+ build-depends: base-orphans >= 0.8 && < 0.9
42
48
43 exposed-modules: Data.Functor.Misc
49 exposed-modules: Data.Functor.Misc
44 , Data.Monoid.DecidablyEmpty
50 , Data.Monoid.DecidablyEmpty
@@ -50,18 +56,34 @@ library
50 , Data.Patch.Map
56 , Data.Patch.Map
51 , Data.Patch.MapWithMove
57 , Data.Patch.MapWithMove
52 , Data.Patch.MapWithPatchingMove
58 , Data.Patch.MapWithPatchingMove
59+ , Data.Semigroup.Additive
53
60
54 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
61 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
62+ default-extensions: PolyKinds
55
63
56 if flag(split-these)
64 if flag(split-these)
57− build-depends: these >= 1 && <1.1
65+ build-depends: these >= 1 && <1.2
58 , semialign >=1 && <1.2
66 , semialign >=1 && <1.2
59 , monoidal-containers >= 0.6 && < 0.7
67 , monoidal-containers >= 0.6 && < 0.7
60 else
68 else
61 build-depends: these >= 0.4 && <0.9
69 build-depends: these >= 0.4 && <0.9
62 , monoidal-containers == 0.4.0.0
70 , monoidal-containers == 0.4.0.0
63
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+
64test-suite hlint
85test-suite hlint
86+ default-language: Haskell2010
65 type: exitcode-stdio-1.0
87 type: exitcode-stdio-1.0
66 main-is: hlint.hs
88 main-is: hlint.hs
67 hs-source-dirs: test
89 hs-source-dirs: test
@@ -69,7 +91,7 @@ test-suite hlint
69 , directory
91 , directory
70 , filepath
92 , filepath
71 , filemanip
93 , filemanip
72− , hlint < 2.1 || >= 2.2.2
94+ , hlint (< 2.1 || >= 2.2.2) && < 3.3
73 if impl(ghcjs)
95 if impl(ghcjs)
74 buildable: False
96 buildable: False
75
97
src/Data/Functor/Misc.hs+2−3
@@ -6,7 +6,6 @@
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 #-}
@@ -48,7 +47,7 @@ import Data.IntMap (IntMap)
48import qualified Data.IntMap as IntMap
47import qualified Data.IntMap as IntMap
49import Data.Map (Map)
48import Data.Map (Map)
50import qualified Data.Map as Map
49import qualified Data.Map as Map
51−import Data.Some (Some(Some))
50+import Data.Some (Some, mkSome)
52import Data.These
51import Data.These
53import Data.Type.Equality ((:~:)(Refl))
52import Data.Type.Equality ((:~:)(Refl))
54import Data.Typeable hiding (Refl)
53import Data.Typeable hiding (Refl)
@@ -117,7 +116,7 @@ intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=
117-- | 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
118-- the keys, using a function to remove the wrapping 'Functor'
117-- the keys, using a function to remove the wrapping 'Functor'
119weakenDMapWith :: (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'
120−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
121
120
122--------------------------------------------------------------------------------
121--------------------------------------------------------------------------------
123-- WrapArg
122-- WrapArg
src/Data/Patch.hs+3−14
@@ -23,6 +23,7 @@ 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,9 +46,6 @@ 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
@@ -58,19 +56,15 @@ instance Additive p => Patch (AdditivePatch p) where
58instance (Ord k, Group q) => Group (MonoidalMap k q) where
56instance (Ord k, Group q) => Group (MonoidalMap k q) where
59 negateG = fmap negateG
57 negateG = fmap negateG
60
58
61−instance (Ord k, Additive q) => Additive (MonoidalMap k q)
62−
63-- | Trivial group.
59-- | Trivial group.
64instance Group () where
60instance Group () where
65 negateG _ = ()
61 negateG _ = ()
66 _ ~~ _ = ()
62 _ ~~ _ = ()
67−instance Additive ()
68
63
69-- | Product group. A Pair of groups gives rise to a group
64-- | Product group. A Pair of groups gives rise to a group
70instance (Group a, Group b) => Group (a, b) where
65instance (Group a, Group b) => Group (a, b) where
71 negateG (a, b) = (negateG a, negateG b)
66 negateG (a, b) = (negateG a, negateG b)
72 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
67 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
73−instance (Additive a, Additive b) => Additive (a, b)
74
68
75-- 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.
76-- 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
@@ -78,29 +72,24 @@ instance (Additive a, Additive b) => Additive (a, b)
78instance Group (f (g a)) => Group ((f :.: g) a) where
72instance Group (f (g a)) => Group ((f :.: g) a) where
79 negateG (Comp1 xs) = Comp1 (negateG xs)
73 negateG (Comp1 xs) = Comp1 (negateG xs)
80 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
74 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
81−instance Additive (f (g a)) => Additive ((f :.: g) a)
82
75
83-- | Product of groups, Functor style.
76-- | Product of groups, Functor style.
84instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
77instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
85 negateG (a :*: b) = negateG a :*: negateG b
78 negateG (a :*: b) = negateG a :*: negateG b
86 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
79 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
87−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
88
80
89-- | Trivial group, Functor style
81-- | Trivial group, Functor style
90instance Group (Proxy x) where
82instance Group (Proxy x) where
91 negateG _ = Proxy
83 negateG _ = Proxy
92 _ ~~ _ = Proxy
84 _ ~~ _ = Proxy
93−instance Additive (Proxy x)
94
85
95-- | Const lifts groups into a functor.
86-- | Const lifts groups into a functor.
96deriving instance Group a => Group (Const a x)
87deriving instance Group a => Group (Const a x)
97−instance Additive a => Additive (Const a x)
88+
98−-- | Ideitnty lifts groups pointwise (at only one point)
89+-- | Identity lifts groups pointwise (at only one point)
99deriving instance Group a => Group (Identity a)
90deriving instance Group a => Group (Identity a)
100−instance Additive a => Additive (Identity a)
101
91
102-- | Functions lift groups pointwise.
92-- | Functions lift groups pointwise.
103instance Group b => Group (a -> b) where
93instance Group b => Group (a -> b) where
104 negateG f = negateG . f
94 negateG f = negateG . f
105 (~~) = liftA2 (~~)
95 (~~) = liftA2 (~~)
106−instance Additive b => Additive (a -> b)
src/Data/Patch/Class.hs+4−2
@@ -1,9 +1,11 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
3-- | The interface for types which represent changes made to other types
4-- | The interface for types which represent changes made to other types
4module Data.Patch.Class where
5module Data.Patch.Class where
5
6
6import Data.Functor.Identity
7import Data.Functor.Identity
8+import Data.Kind (Type)
7import Data.Maybe
9import Data.Maybe
8#if !MIN_VERSION_base(4,11,0)
10#if !MIN_VERSION_base(4,11,0)
9import Data.Semigroup (Semigroup(..))
11import Data.Semigroup (Semigroup(..))
@@ -15,7 +17,7 @@ import Data.Proxy
15-- 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
16-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
18-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
17class Patch p where
19class Patch p where
18− type PatchTarget p :: *
20+ type PatchTarget p :: Type
19 -- | 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
20 -- 'Nothing'.
22 -- 'Nothing'.
21 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
23 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -30,7 +32,7 @@ instance Patch (Identity a) where
30 apply (Identity a) _ = Just a
32 apply (Identity a) _ = Just a
31
33
32-- | 'Proxy' can be used as a 'Patch' that does nothing.
34-- | 'Proxy' can be used as a 'Patch' that does nothing.
33−instance Patch (Proxy a) where
35+instance forall (a :: Type). Patch (Proxy a) where
34 type PatchTarget (Proxy a) = a
36 type PatchTarget (Proxy a) = a
35 apply ~Proxy _ = Nothing
37 apply ~Proxy _ = Nothing
36
38
src/Data/Patch/DMap.hs+3−1
@@ -14,7 +14,9 @@ import Data.Patch.Class
14import Data.Patch.IntMap
14import Data.Patch.IntMap
15import Data.Patch.Map
15import Data.Patch.Map
16
16
17−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 (..))
18import qualified Data.Dependent.Map as DMap
20import qualified Data.Dependent.Map as DMap
19import Data.Functor.Constant
21import Data.Functor.Constant
20import Data.Functor.Misc
22import Data.Functor.Misc
src/Data/Patch/DMapWithMove.hs+8−7
@@ -20,12 +20,13 @@ import Data.Patch.MapWithMove (PatchMapWithMove (..))
20import qualified Data.Patch.MapWithMove as MapWithMove
20import qualified Data.Patch.MapWithMove as MapWithMove
21
21
22import Data.Constraint.Extras
22import Data.Constraint.Extras
23−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
23+import Data.Dependent.Map (DMap)
24+import Data.Dependent.Sum (DSum (..))
24import qualified Data.Dependent.Map as DMap
25import qualified Data.Dependent.Map as DMap
25import Data.Functor.Constant
26import Data.Functor.Constant
26import Data.Functor.Misc
27import Data.Functor.Misc
27import Data.Functor.Product
28import Data.Functor.Product
28−import Data.GADT.Compare (GEq (..))
29+import Data.GADT.Compare (GEq (..), GCompare (..))
29import Data.GADT.Show (GShow, gshow)
30import Data.GADT.Show (GShow, gshow)
30import qualified Data.Map as Map
31import qualified Data.Map as Map
31import Data.Maybe
32import Data.Maybe
@@ -33,7 +34,7 @@ import Data.Monoid.DecidablyEmpty
33#if !MIN_VERSION_base(4,11,0)
34#if !MIN_VERSION_base(4,11,0)
34import Data.Semigroup (Semigroup (..))
35import Data.Semigroup (Semigroup (..))
35#endif
36#endif
36−import Data.Some (Some(Some))
37+import Data.Some (Some, mkSome)
37import Data.These
38import Data.These
38
39
39-- | 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
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
@@ -219,8 +220,8 @@ moveDMapKey src dst = case src `geq` dst of
219-- @
220-- @
220-- let aMay = DMap.lookup a dmap
221-- let aMay = DMap.lookup a dmap
221-- bMay = DMap.lookup b dmap
222-- bMay = DMap.lookup b dmap
222−-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
223+-- in maybe id (DMap.insert a) (bMay <> aMay)
223−-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
224+-- . maybe id (DMap.insert b) (aMay <> bMay)
224-- . DMap.delete a . DMap.delete b $ dmap
225-- . DMap.delete a . DMap.delete b $ dmap
225-- @
226-- @
226swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
@@ -317,8 +318,8 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
317 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
318 From_Insert v -> MapWithMove.From_Insert $ f v
319 From_Insert v -> MapWithMove.From_Insert $ f v
319 From_Delete -> MapWithMove.From_Delete
320 From_Delete -> MapWithMove.From_Delete
320− From_Move k -> MapWithMove.From_Move $ Some k
321+ From_Move k -> MapWithMove.From_Move $ mkSome k
321− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
322+ , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
322 }
323 }
323
324
324-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k 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
src/Data/Patch/IntMap.hs+1−1
@@ -59,7 +59,7 @@ mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k m
59-- | 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@
60-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
60-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
61traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
61traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
62−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
63
63
64-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
64-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
65patchIntMapNewElements :: PatchIntMap a -> [a]
65patchIntMapNewElements :: PatchIntMap a -> [a]
src/Data/Patch/MapWithMove.hs+169−53
@@ -8,28 +8,65 @@
8{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE PatternSynonyms #-}
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
11{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
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
17module Data.Patch.MapWithMove
19module Data.Patch.MapWithMove
18− ( module Data.Patch.MapWithMove
20+ ( PatchMapWithMove
19− , PatchMapWithMove (PatchMapWithMove)
21+ ( PatchMapWithMove
22+ , unPatchMapWithMove
23+ , ..
24+ )
25+ , patchMapWithMove
26+ , patchMapWithMoveInsertAll
27+ , insertMapKey
28+ , moveMapKey
29+ , swapMapKey
30+ , deleteMapKey
31+ , unsafePatchMapWithMove
32+ , patchMapWithMoveNewElements
33+ , patchMapWithMoveNewElementsMap
34+ , patchThatSortsMapWith
35+ , patchThatChangesAndSortsMapWith
36+ , patchThatChangesMap
37+
38+ -- * Node Info
20 , NodeInfo
39 , NodeInfo
21− , pattern PM.NodeInfo
40+ ( NodeInfo
22− , PM._nodeInfo_to
41+ , _nodeInfo_to
23− , PM._nodeInfo_from
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
24 ) where
61 ) where
25
62
63+import Data.Coerce
64+import Data.Kind (Type)
26import Data.Patch.Class
65import Data.Patch.Class
27−import Data.Patch.MapWithPatchingMove
66+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
28− ( PatchMapWithPatchingMove (..)
29− )
30−import qualified Data.Patch.MapWithPatchingMove as PM
67+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
31
68
32−import Control.Lens hiding (from, to)
69+import Control.Lens
33import Data.List
70import Data.List
34import Data.Map (Map)
71import Data.Map (Map)
35import qualified Data.Map as Map
72import qualified Data.Map as Map
@@ -42,21 +79,40 @@ import Data.Traversable (foldMapDefault)
42-- | 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@
43-- 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@,
44-- 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.
45−newtype PatchMapWithMove k v = PatchMapWithMove'
82+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
46 { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
83 { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
47 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
84 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
48 }
85 }
49 deriving ( Show, Read, Eq, Ord
86 deriving ( Show, Read, Eq, Ord
87+-- Haddock cannot handle documentation here before GHC 8.6
88+ ,
89+#if __GLASGOW_HASKELL__ >= 806
90+ -- | Compose patches having the same effect as applying the
91+ -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92+ -- 'applyAlways' q@
93+#endif
50− , Semigroup, Monoid
94+ Semigroup
95+ , Monoid
51 )
96 )
52
97
98+pattern Coerce :: Coercible a b => a -> b
99+pattern Coerce x <- (coerce -> x)
100+ where Coerce x = coerce x
101+
53{-# COMPLETE PatchMapWithMove #-}
102{-# COMPLETE PatchMapWithMove #-}
54pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
103pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
55−pattern PatchMapWithMove m = PatchMapWithMove' (PatchMapWithPatchingMove m)
56−
57−-- | Extract the internal representation of the 'PatchMapWithMove'
104+-- | Extract the representation of the 'PatchMapWithMove' as a map of
105+-- 'NodeInfo'.
58−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (PM.NodeInfo k (Proxy v))
106+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
59−unPatchMapWithMove = unPatchMapWithPatchingMove . unPatchMapWithMove'
107+pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
108+
109+_PatchMapWithMove
110+ :: Iso
111+ (PatchMapWithMove k0 v0)
112+ (PatchMapWithMove k1 v1)
113+ (Map k0 (NodeInfo k0 v0))
114+ (Map k1 (NodeInfo k1 v1))
115+_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
60
116
61instance Functor (PatchMapWithMove k) where
117instance Functor (PatchMapWithMove k) where
62 fmap f = runIdentity . traverse (Identity . f)
118 fmap f = runIdentity . traverse (Identity . f)
@@ -66,45 +122,22 @@ instance Foldable (PatchMapWithMove k) where
66
122
67instance Traversable (PatchMapWithMove k) where
123instance Traversable (PatchMapWithMove k) where
68 traverse =
124 traverse =
69− _Wrapping PatchMapWithMove' .
125+ _PatchMapWithMove .
70− _Wrapping PatchMapWithPatchingMove .
71 traverse .
126 traverse .
72− traverseNodeInfo
127+ traverse
73
128
74instance FunctorWithIndex k (PatchMapWithMove k)
129instance FunctorWithIndex k (PatchMapWithMove k)
75instance FoldableWithIndex k (PatchMapWithMove k)
130instance FoldableWithIndex k (PatchMapWithMove k)
76instance TraversableWithIndex k (PatchMapWithMove k) where
131instance TraversableWithIndex k (PatchMapWithMove k) where
77 itraverse = itraversed . Indexed
132 itraverse = itraversed . Indexed
78 itraversed =
133 itraversed =
79− _Wrapping PatchMapWithMove' .>
134+ _PatchMapWithMove .>
80− _Wrapping PatchMapWithPatchingMove .>
81 itraversed <.
135 itraversed <.
82− traverseNodeInfo
136+ traverse
83−
84−type NodeInfo k v = PM.NodeInfo k (Proxy v)
85−
86−type From k v = PM.From k (Proxy v)
87−
88−{-# COMPLETE From_Insert, From_Delete, From_Move #-}
89−
90−pattern From_Insert :: v -> From k v
91−pattern From_Insert v = PM.From_Insert v
92−
93−pattern From_Delete :: From k v
94−pattern From_Delete = PM.From_Delete
95−
96−pattern From_Move :: k -> From k v
97−pattern From_Move k = PM.From_Move k Proxy
98−
99−type To k = PM.To k
100−
101−traverseNodeInfo
102− :: Traversal (NodeInfo k a) (NodeInfo k b) a b
103−traverseNodeInfo = PM.bitraverseNodeInfo pure (\(~Proxy) -> pure Proxy)
104
137
105-- | Create a 'PatchMapWithMove', validating it
138-- | Create a 'PatchMapWithMove', validating it
106patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
139patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
107−patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove
140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
108
141
109-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
110patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
@@ -127,8 +160,8 @@ moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
127-- @
160-- @
128-- let aMay = Map.lookup a map
161-- let aMay = Map.lookup a map
129-- bMay = Map.lookup b map
162-- bMay = Map.lookup b map
130−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
163+-- in maybe id (Map.insert a) (bMay <> aMay)
131−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
164+-- . maybe id (Map.insert b) (aMay <> bMay)
132-- . Map.delete a . Map.delete b $ map
165-- . Map.delete a . Map.delete b $ map
133-- @
166-- @
134swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
167swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
@@ -142,12 +175,12 @@ deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
142--
175--
143-- __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.
144unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
145−unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove
178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
146
179
147-- | Apply the insertions, deletions, and moves to a given 'Map'
180-- | Apply the insertions, deletions, and moves to a given 'Map'
148instance Ord k => Patch (PatchMapWithMove k v) where
181instance Ord k => Patch (PatchMapWithMove k v) where
149 type PatchTarget (PatchMapWithMove k v) = Map k v
182 type PatchTarget (PatchMapWithMove k v) = Map k v
150− apply (PatchMapWithMove' p) old = apply p old
183+ apply (PatchMapWithMove' p) = apply p
151
184
152-- | 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'.
153patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
186patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
@@ -166,7 +199,7 @@ patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
166-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
167-- 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
168-- values sorted with the given ordering function.
201-- values sorted with the given ordering function.
169−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
202+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
170patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
171 where newList = Map.toList newByIndexUnsorted
204 where newList = Map.toList newByIndexUnsorted
172 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
@@ -177,9 +210,58 @@ patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove
177patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
210patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
178 PM.patchThatChangesMap oldByIndex newByIndex
211 PM.patchThatChangesMap oldByIndex newByIndex
179
212
213+--
214+-- NodeInfo
215+--
216+
217+-- | Holds the information about each key: where its new value should come from,
218+-- and where its old value should go to
219+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
220+
221+deriving instance (Show k, Show p) => Show (NodeInfo k p)
222+deriving instance (Read k, Read p) => Read (NodeInfo k p)
223+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
224+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
225+
226+{-# COMPLETE NodeInfo #-}
227+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
228+_nodeInfo_to :: NodeInfo k v -> To k
229+_nodeInfo_from :: NodeInfo k v -> From k v
230+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
231+ PM.NodeInfo
232+ { PM._nodeInfo_to = _nodeInfo_to
233+ , PM._nodeInfo_from = Coerce _nodeInfo_from
234+ }
235+
236+_NodeInfo
237+ :: Iso
238+ (NodeInfo k0 v0)
239+ (NodeInfo k1 v1)
240+ (PM.NodeInfo k0 (Proxy v0))
241+ (PM.NodeInfo k1 (Proxy v1))
242+_NodeInfo = iso unNodeInfo' NodeInfo'
243+
244+instance Functor (NodeInfo k) where
245+ fmap f = runIdentity . traverse (Identity . f)
246+
247+instance Foldable (NodeInfo k) where
248+ foldMap = foldMapDefault
249+
250+instance Traversable (NodeInfo k) where
251+ traverse = bitraverseNodeInfo pure
252+
253+bitraverseNodeInfo
254+ :: Applicative f
255+ => (k0 -> f k1)
256+ -> (v0 -> f v1)
257+ -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258+bitraverseNodeInfo fk fv = fmap NodeInfo'
259+ . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260+ . coerce
261+
180-- | Change the 'From' value of a 'NodeInfo'
262-- | Change the 'From' value of a 'NodeInfo'
181nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
263nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
182−nodeInfoMapFrom = PM.nodeInfoMapFrom
264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
183
265
184-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
185-- 'Applicative', 'Monad', etc.) action to get the new value
267-- 'Applicative', 'Monad', etc.) action to get the new value
@@ -187,10 +269,44 @@ nodeInfoMapMFrom
187 :: Functor f
269 :: Functor f
188 => (From k v -> f (From k v))
270 => (From k v -> f (From k v))
189 -> NodeInfo k v -> f (NodeInfo k v)
271 -> NodeInfo k v -> f (NodeInfo k v)
272+nodeInfoMapMFrom f = fmap NodeInfo'
190−nodeInfoMapMFrom = PM.nodeInfoMapMFrom
273+ . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274+ . coerce
191
275
192-- | Set the 'To' field of a 'NodeInfo'
276-- | Set the 'To' field of a 'NodeInfo'
193nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
277nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
194−nodeInfoSetTo = PM.nodeInfoSetTo
278+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
279+
280+--
281+-- From
282+--
283+
284+-- | Describe how a key's new value should be produced
285+newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
286+
287+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
288+
289+-- | Insert the given value here
290+pattern From_Insert :: v -> From k v
291+pattern From_Insert v = From' (PM.From_Insert v)
292+
293+-- | Delete the existing value, if any, from here
294+pattern From_Delete :: From k v
295+pattern From_Delete = From' PM.From_Delete
296+
297+-- | Move the value here from the given key
298+pattern From_Move :: k -> From k v
299+pattern From_Move k = From' (PM.From_Move k Proxy)
300+
301+bitraverseFrom
302+ :: Applicative f
303+ => (k0 -> f k1)
304+ -> (v0 -> f v1)
305+ -> From k0 v0 -> f (From k1 v1)
306+bitraverseFrom fk fv = fmap From'
307+ . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308+ . coerce
195
309
196makeWrapped ''PatchMapWithMove
310makeWrapped ''PatchMapWithMove
311+makeWrapped ''NodeInfo
312+makeWrapped ''From
src/Data/Patch/MapWithPatchingMove.hs+140−86
@@ -13,14 +13,45 @@
13
13
14-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
14-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15-- another
15-- another
16−module Data.Patch.MapWithPatchingMove where
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
17
48
18import Data.Patch.Class
49import Data.Patch.Class
19
50
20−import Control.Arrow
51+import Control.Lens hiding (from, to)
21import Control.Lens.TH (makeWrapped)
52import Control.Lens.TH (makeWrapped)
22−import Control.Monad.Trans.State
53+import Data.Align (align)
23−import Data.Foldable
54+import Data.Foldable (toList)
24import Data.Function
55import Data.Function
25import Data.List
56import Data.List
26import Data.Map (Map)
57import Data.Map (Map)
@@ -30,9 +61,9 @@ import Data.Maybe
30import Data.Semigroup (Semigroup (..))
61import Data.Semigroup (Semigroup (..))
31#endif
62#endif
32import Data.Monoid.DecidablyEmpty
63import Data.Monoid.DecidablyEmpty
64+import Data.Set (Set)
33import qualified Data.Set as Set
65import qualified Data.Set as Set
34import Data.These (These (..))
66import Data.These (These (..))
35−import Data.Tuple
36
67
37-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
68-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
38-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
69-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -55,57 +86,6 @@ deriving instance ( Ord k
55 , Patch p
86 , Patch p
56 ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
87 ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
57
88
58−-- | Holds the information about each key: where its new value should come from,
59−-- and where its old value should go to
60−data NodeInfo k p = NodeInfo
61− { _nodeInfo_from :: !(From k p)
62− -- ^ Where do we get the new value for this key?
63− , _nodeInfo_to :: !(To k)
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−
72−bitraverseNodeInfo
73− :: Applicative f
74− => (k0 -> f k1)
75− -> (p0 -> f p1)
76− -> (PatchTarget p0 -> f (PatchTarget p1))
77− -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
78−bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
79− <$> bitraverseFrom fk fp fpt from
80− <*> traverse fk to
81−
82−-- | Describe how a key's new value should be produced
83−data From k p
84− = From_Insert (PatchTarget p) -- ^ Insert the given value here
85− | From_Delete -- ^ Delete the existing value, if any, from here
86− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
87−
88−bitraverseFrom
89− :: Applicative f
90− => (k0 -> f k1)
91− -> (p0 -> f p1)
92− -> (PatchTarget p0 -> f (PatchTarget p1))
93− -> From k0 p0 -> f (From k1 p1)
94−bitraverseFrom fk fp fpt = \case
95− From_Insert pt -> From_Insert <$> fpt pt
96− From_Delete -> pure From_Delete
97− From_Move k p -> From_Move <$> fk k <*> fp p
98−
99−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
100−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
101−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
102−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
103−
104−-- | Describe where a key's old value will go. If this is 'Just', that means
105−-- the key's old value will be moved to the given other key; if it is 'Nothing',
106−-- that means it will be deleted.
107−type To = Maybe
108−
109-- | Create a 'PatchMapWithPatchingMove', validating it
89-- | Create a 'PatchMapWithPatchingMove', validating it
110patchMapWithPatchingMove
90patchMapWithPatchingMove
111 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
91 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
@@ -156,8 +136,8 @@ moveMapKey src dst
156-- @
136-- @
157-- let aMay = Map.lookup a map
137-- let aMay = Map.lookup a map
158-- bMay = Map.lookup b map
138-- bMay = Map.lookup b map
159−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
139+-- in maybe id (Map.insert a) (bMay <> aMay)
160−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
140+-- . maybe id (Map.insert b) (aMay <> bMay)
161-- . Map.delete a . Map.delete b $ map
141-- . Map.delete a . Map.delete b $ map
162-- @
142-- @
163swapMapKey
143swapMapKey
@@ -249,37 +229,70 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
249
229
250-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251-- will produce the second 'Map'.
231-- will produce the second 'Map'.
232+-- Note: this will never produce a patch on a value.
252patchThatChangesMap
233patchThatChangesMap
234+ :: forall k p
253− :: (Ord k, Ord (PatchTarget p), Monoid p)
235+ . (Ord k, Ord (PatchTarget p), Monoid p)
254 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
255patchThatChangesMap oldByIndex newByIndex = patch
237patchThatChangesMap oldByIndex newByIndex = patch
256− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
238+ where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
257− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
239+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
258− let f k v = do
240+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
259− remainingValues <- get
241+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
260− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
242+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
261− then Map.delete v remainingValues
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))
262− else Map.insert v remainingKeys remainingValues
244+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
263− case Map.lookup v remainingValues of
245+ -- Generate patch info for a single value
264− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
246+ -- Keys that are found in both the old and new sets will not be patched
265− Just fromKs ->
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
266− if k `Set.member` fromKs
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
267− then do
249+ patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
268− putRemainingKeys $ Set.delete k fromKs
250+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
269− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
251+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
270− else do
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
271− (fromK, remainingKeys) <- return . fromMaybe (error "patchThatChangesMap: impossible: fromKs was empty") $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
253+ These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
272− putRemainingKeys remainingKeys
254+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
273− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
255+ patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
274− Map.traverseWithKey f newByIndex
256+ patchSingleValueThese v = \case
275− unusedOldKeys = fold unusedValuesByValue
257+ This oldKeys -> patchSingleValue v oldKeys mempty
276− pointlessMove k = \case
258+ That newKeys -> patchSingleValue v mempty newKeys
277− From_Move k' _ | k == k' -> True
259+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
278− _ -> False
260+ -- Generate froms and tos for all values, then merge them together
279− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
261+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
280− then Just undefined
262+ patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
281− else Nothing
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.
282− patch = unsafePatchMapWithPatchingMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
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
283
296
284-- | Change the 'From' value of a 'NodeInfo'
297-- | Change the 'From' value of a 'NodeInfo'
285nodeInfoMapFrom
298nodeInfoMapFrom
@@ -297,6 +310,47 @@ nodeInfoSetTo
297 :: To k -> NodeInfo k v -> NodeInfo k v
310 :: To k -> NodeInfo k v -> NodeInfo k v
298nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
311nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
299
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+
300-- | Helper data structure used for composing patches using the monoid instance.
354-- | Helper data structure used for composing patches using the monoid instance.
301data Fixup k v
355data Fixup k v
302 = Fixup_Delete
356 = Fixup_Delete
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