git.iko.soy/patch
on 09fe276 help sign in
b6af869
swap
0 ahead, 46 behind
.github/workflows/haskell.ymldeleted−47
since splitsnapshots
unifiedsplit
@@ -1,47 +0,0 @@
1−name: github-action
2−
3−on: [push, pull_request]
4−
5−jobs:
6− build:
7− strategy:
8− matrix:
9− ghc: ['8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.2']
10− os: ['ubuntu-latest', 'macos-latest']
11− exclude:
12− # There are some linker warnings in 802 on darwin that
13− # cause compilation to fail
14− # See https://github.com/NixOS/nixpkgs/issues/25139
15− - ghc: '8.0.2'
16− os: 'macos-latest'
17− runs-on: ${{ matrix.os }}
18−
19− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
20− steps:
21− - uses: actions/checkout@v2
22− - uses: actions/setup-haskell@v1
23− with:
24− ghc-version: ${{ matrix.ghc }}
25− - name: Cache
26− uses: actions/cache@v1
27− env:
28− cache-name: cache-cabal
29− with:
30− path: ~/.cabal
31− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
32− restore-keys: |
33− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
34− ${{ runner.os }}-${{ matrix.ghc }}-build-
35− ${{ runner.os }}-${{ matrix.ghc }}-
36− ${{ runner.os }}
37−
38− - name: Install dependencies
39− run: |
40− cabal update
41− cabal build --only-dependencies --enable-tests --enable-benchmarks
42− - name: Build
43− run: cabal build --enable-tests --enable-benchmarks all
44− - name: Run tests
45− run: cabal test --enable-tests all
46− - name: Build Docs
47− run: cabal haddock
.travis.ymlnew file+171
@@ -0,0 +1,171 @@
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
ChangeLog.md+9−23
@@ -2,39 +2,25 @@
2
2
3## Unreleased
3## Unreleased
4
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`.
5* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
14− Care is taken to make this not a breaking change.
6+ Care is taken to make this as little of a breaking change as possible.
15− In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
7+ In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove` as is the `NodeInfo` of `PatchMapWithPatchingMove`'s `NodeInfo`.
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
8
23−## 0.0.3.2 - 2020-11-06
9+## 0.0.3.2
24
10
25* Update version bounds
11* Update version bounds
26
12
27−## 0.0.3.1 - 2020-02-05
13+## 0.0.3.1
28
14
29* Replace `fromJust` with something easier to debug.
15* Replace `fromJust` with something easier to debug.
30
16
31−## 0.0.3.0 - 2020-02-05
17+## 0.0.3.0
32
18
33* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
19* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
34
20
35* Create `DecidablyEmpty` subclass of `Monoid`.
21* Create `DecidablyEmpty` subclass of `Monoid`.
36
22
37−## 0.0.2.0 - 2020-01-17
23+## 0.0.2.0
38
24
39* Consistently provide:
25* Consistently provide:
40
26
@@ -46,16 +32,16 @@
46
32
47 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
33 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
48
34
49−## 0.0.1.0 - 2020-01-09
35+## 0.0.1.0
50
36
51* Support older GHCs with `split-these` flag.
37* Support older GHCs with `split-these` flag.
52
38
53* Additional instances for the `Group` class for basic types.
39* Additional instances for the `Group` class for basic types.
54
40
55−## 0.0.0.1 - 2020-01-08
41+## 0.0.0.1
56
42
57* Remove unneeded dependencies
43* Remove unneeded dependencies
58
44
59−## 0.0.0.0 - 2020-01-08
45+## 0.0.0.0
60
46
61* Extract patching functionality from Reflex.
47* Extract patching functionality from Reflex.
cabal.haskell-cinew file+14
@@ -0,0 +1,14 @@
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+4−22
@@ -1,5 +1,5 @@
1Name: patch
1Name: patch
2−Version: 0.0.5.0
2+Version: 0.0.3.2
3Synopsis: Data structures for describing changes to other data structures.
3Synopsis: Data structures for describing changes to other data structures.
4Description:
4Description:
5 Data structures for describing changes to other data structures.
5 Data structures for describing changes to other data structures.
@@ -33,7 +33,7 @@ flag split-these
33library
33library
34 hs-source-dirs: src
34 hs-source-dirs: src
35 default-language: Haskell2010
35 default-language: Haskell2010
36− build-depends: base >= 4.9 && < 4.15
36+ build-depends: base >= 4.9 && < 4.14
37 , constraints-extras >= 0.3 && < 0.4
37 , constraints-extras >= 0.3 && < 0.4
38 , containers >= 0.6 && < 0.7
38 , containers >= 0.6 && < 0.7
39 , dependent-map >= 0.3 && < 0.5
39 , dependent-map >= 0.3 && < 0.5
@@ -41,10 +41,7 @@ library
41 , lens >= 4.7 && < 5
41 , lens >= 4.7 && < 5
42 , semigroupoids >= 4.0 && < 6
42 , semigroupoids >= 4.0 && < 6
43 , transformers >= 0.5.6.0 && < 0.6
43 , transformers >= 0.5.6.0 && < 0.6
44− , witherable >= 0.3 && < 0.5
44+ , witherable >= 0.3 && < 0.4
45−
46− if impl(ghc < 8.6) -- really, if base < 8.12
47− build-depends: base-orphans >= 0.8 && < 0.9
48
45
49 exposed-modules: Data.Functor.Misc
46 exposed-modules: Data.Functor.Misc
50 , Data.Monoid.DecidablyEmpty
47 , Data.Monoid.DecidablyEmpty
@@ -56,10 +53,8 @@ library
56 , Data.Patch.Map
53 , Data.Patch.Map
57 , Data.Patch.MapWithMove
54 , Data.Patch.MapWithMove
58 , Data.Patch.MapWithPatchingMove
55 , Data.Patch.MapWithPatchingMove
59− , Data.Semigroup.Additive
60
56
61 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
57 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
62− default-extensions: PolyKinds
63
58
64 if flag(split-these)
59 if flag(split-these)
65 build-depends: these >= 1 && <1.2
60 build-depends: these >= 1 && <1.2
@@ -69,19 +64,6 @@ library
69 build-depends: these >= 0.4 && <0.9
64 build-depends: these >= 0.4 && <0.9
70 , monoidal-containers == 0.4.0.0
65 , monoidal-containers == 0.4.0.0
71
66
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−
85test-suite hlint
67test-suite hlint
86 default-language: Haskell2010
68 default-language: Haskell2010
87 type: exitcode-stdio-1.0
69 type: exitcode-stdio-1.0
@@ -91,7 +73,7 @@ test-suite hlint
91 , directory
73 , directory
92 , filepath
74 , filepath
93 , filemanip
75 , filemanip
94− , hlint (< 2.1 || >= 2.2.2) && < 3.3
76+ , hlint (< 2.1 || >= 2.2.2) && < 3
95 if impl(ghcjs)
77 if impl(ghcjs)
96 buildable: False
78 buildable: False
97
79
src/Data/Patch.hs+14−3
@@ -23,7 +23,6 @@ import Data.Semigroup (Semigroup (..))
23#endif
23#endif
24import GHC.Generics
24import GHC.Generics
25
25
26−import Data.Semigroup.Additive as X
27import Data.Patch.Class as X
26import Data.Patch.Class as X
28import Data.Patch.DMap as X hiding (getDeletions)
27import Data.Patch.DMap as X hiding (getDeletions)
29import Data.Patch.DMapWithMove as X
28import Data.Patch.DMapWithMove as X
@@ -46,6 +45,9 @@ class (Semigroup q, Monoid q) => Group q where
46 (~~) :: q -> q -> q
45 (~~) :: q -> q -> q
47 r ~~ s = r <> negateG s
46 r ~~ s = r <> negateG s
48
47
48+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
49+class Semigroup q => Additive q where
50+
49-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
51-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
50newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
52newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
51
53
@@ -56,15 +58,19 @@ instance Additive p => Patch (AdditivePatch p) where
56instance (Ord k, Group q) => Group (MonoidalMap k q) where
58instance (Ord k, Group q) => Group (MonoidalMap k q) where
57 negateG = fmap negateG
59 negateG = fmap negateG
58
60
61+instance (Ord k, Additive q) => Additive (MonoidalMap k q)
62+
59-- | Trivial group.
63-- | Trivial group.
60instance Group () where
64instance Group () where
61 negateG _ = ()
65 negateG _ = ()
62 _ ~~ _ = ()
66 _ ~~ _ = ()
67+instance Additive ()
63
68
64-- | Product group. A Pair of groups gives rise to a group
69-- | Product group. A Pair of groups gives rise to a group
65instance (Group a, Group b) => Group (a, b) where
70instance (Group a, Group b) => Group (a, b) where
66 negateG (a, b) = (negateG a, negateG b)
71 negateG (a, b) = (negateG a, negateG b)
67 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
72 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
73+instance (Additive a, Additive b) => Additive (a, b)
68
74
69-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
75-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
70-- Base does not define Monoid (Compose f g a) so this is the best we can
76-- Base does not define Monoid (Compose f g a) so this is the best we can
@@ -72,24 +78,29 @@ instance (Group a, Group b) => Group (a, b) where
72instance Group (f (g a)) => Group ((f :.: g) a) where
78instance Group (f (g a)) => Group ((f :.: g) a) where
73 negateG (Comp1 xs) = Comp1 (negateG xs)
79 negateG (Comp1 xs) = Comp1 (negateG xs)
74 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
80 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
81+instance Additive (f (g a)) => Additive ((f :.: g) a)
75
82
76-- | Product of groups, Functor style.
83-- | Product of groups, Functor style.
77instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
84instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
78 negateG (a :*: b) = negateG a :*: negateG b
85 negateG (a :*: b) = negateG a :*: negateG b
79 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
86 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
87+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
80
88
81-- | Trivial group, Functor style
89-- | Trivial group, Functor style
82instance Group (Proxy x) where
90instance Group (Proxy x) where
83 negateG _ = Proxy
91 negateG _ = Proxy
84 _ ~~ _ = Proxy
92 _ ~~ _ = Proxy
93+instance Additive (Proxy x)
85
94
86-- | Const lifts groups into a functor.
95-- | Const lifts groups into a functor.
87deriving instance Group a => Group (Const a x)
96deriving instance Group a => Group (Const a x)
88−
97+instance Additive a => Additive (Const a x)
89−-- | Identity lifts groups pointwise (at only one point)
98+-- | Ideitnty lifts groups pointwise (at only one point)
90deriving instance Group a => Group (Identity a)
99deriving instance Group a => Group (Identity a)
100+instance Additive a => Additive (Identity a)
91
101
92-- | Functions lift groups pointwise.
102-- | Functions lift groups pointwise.
93instance Group b => Group (a -> b) where
103instance Group b => Group (a -> b) where
94 negateG f = negateG . f
104 negateG f = negateG . f
95 (~~) = liftA2 (~~)
105 (~~) = liftA2 (~~)
106+instance Additive b => Additive (a -> b)
src/Data/Patch/Class.hs+2−4
@@ -1,11 +1,9 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
4-- | The interface for types which represent changes made to other types
3-- | The interface for types which represent changes made to other types
5module Data.Patch.Class where
4module Data.Patch.Class where
6
5
7import Data.Functor.Identity
6import Data.Functor.Identity
8−import Data.Kind (Type)
9import Data.Maybe
7import Data.Maybe
10#if !MIN_VERSION_base(4,11,0)
8#if !MIN_VERSION_base(4,11,0)
11import Data.Semigroup (Semigroup(..))
9import Data.Semigroup (Semigroup(..))
@@ -17,7 +15,7 @@ import Data.Proxy
17-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
15-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
18-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
16-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
19class Patch p where
17class Patch p where
20− type PatchTarget p :: Type
18+ type PatchTarget p :: *
21 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
19 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
22 -- 'Nothing'.
20 -- 'Nothing'.
23 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
21 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -32,7 +30,7 @@ instance Patch (Identity a) where
32 apply (Identity a) _ = Just a
30 apply (Identity a) _ = Just a
33
31
34-- | 'Proxy' can be used as a 'Patch' that does nothing.
32-- | 'Proxy' can be used as a 'Patch' that does nothing.
35−instance forall (a :: Type). Patch (Proxy a) where
33+instance Patch (Proxy a) where
36 type PatchTarget (Proxy a) = a
34 type PatchTarget (Proxy a) = a
37 apply ~Proxy _ = Nothing
35 apply ~Proxy _ = Nothing
38
36
src/Data/Patch/DMapWithMove.hs+2−2
@@ -220,8 +220,8 @@ moveDMapKey src dst = case src `geq` dst of
220-- @
220-- @
221-- let aMay = DMap.lookup a dmap
221-- let aMay = DMap.lookup a dmap
222-- bMay = DMap.lookup b dmap
222-- bMay = DMap.lookup b dmap
223−-- in maybe id (DMap.insert a) (bMay <> aMay)
223+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
224−-- . maybe id (DMap.insert b) (aMay <> bMay)
224+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
225-- . DMap.delete a . DMap.delete b $ dmap
225-- . DMap.delete a . DMap.delete b $ dmap
226-- @
226-- @
227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
src/Data/Patch/MapWithMove.hs+72−140
@@ -8,7 +8,6 @@
8{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE PatternSynonyms #-}
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE StandaloneDeriving #-}
12{-# LANGUAGE TemplateHaskell #-}
11{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeApplications #-}
14{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
@@ -17,56 +16,32 @@
17-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
16-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
18-- another
17-- another
19module Data.Patch.MapWithMove
18module Data.Patch.MapWithMove
19+ ( module Data.Patch.MapWithMove
20− ( PatchMapWithMove
20+ , PatchMapWithMove
21 ( PatchMapWithMove
21 ( PatchMapWithMove
22+ , -- | Extract the representation of the 'PatchMapWithMove' as a map of
23+ -- 'NodeInfo'.
22− , unPatchMapWithMove
24+ unPatchMapWithMove
23 , ..
25 , ..
24 )
26 )
25− , patchMapWithMove
26− , patchMapWithMoveInsertAll
27− , insertMapKey
28− , moveMapKey
29− , swapMapKey
30− , deleteMapKey
31− , unsafePatchMapWithMove
32− , patchMapWithMoveNewElements
33− , patchMapWithMoveNewElementsMap
34− , patchThatSortsMapWith
35− , patchThatChangesAndSortsMapWith
36− , patchThatChangesMap
37−
38− -- * Node Info
39 , NodeInfo
27 , NodeInfo
40 ( NodeInfo
28 ( NodeInfo
41 , _nodeInfo_to
29 , _nodeInfo_to
42 , _nodeInfo_from
30 , _nodeInfo_from
43 , ..
31 , ..
44 )
32 )
45− , bitraverseNodeInfo
33+ -- TODO export these under the type consructor once GHC is fixed
46− , nodeInfoMapFrom
47− , nodeInfoMapMFrom
48− , nodeInfoSetTo
49−
50− -- * From
51− , From
52− ( From_Insert
34+ -- , From (From_Insert, From_Delete, From_Move)
53− , From_Delete
54− , From_Move
55− , ..
56− )
57− , bitraverseFrom
58−
59− -- * To
60− , To
61 ) where
35 ) where
62
36
63import Data.Coerce
37import Data.Coerce
64−import Data.Kind (Type)
65import Data.Patch.Class
38import Data.Patch.Class
66−import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
39+import Data.Patch.MapWithPatchingMove
40+ ( PatchMapWithPatchingMove (..)
41+ )
67−import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
42+import qualified Data.Patch.MapWithPatchingMove as PM
68
43
69−import Control.Lens
44+import Control.Lens hiding (from, to)
70import Data.List
45import Data.List
71import Data.Map (Map)
46import Data.Map (Map)
72import qualified Data.Map as Map
47import qualified Data.Map as Map
@@ -79,32 +54,22 @@ import Data.Traversable (foldMapDefault)
79-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
54-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
80-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
55-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
81-- and vice versa. There should never be any unpaired From/To keys.
56-- and vice versa. There should never be any unpaired From/To keys.
82−newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
57+newtype PatchMapWithMove k v = PatchMapWithMove'
83 { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
58 { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
84 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
59 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
85 }
60 }
86 deriving ( Show, Read, Eq, Ord
61 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
62+ , -- | Compose patches having the same effect as applying the
91 -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
63 -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92 -- 'applyAlways' q@
64 -- 'applyAlways' q@
93−#endif
94 Semigroup
65 Semigroup
95 , Monoid
66 , Monoid
96 )
67 )
97
68
98−pattern Coerce :: Coercible a b => a -> b
99−pattern Coerce x <- (coerce -> x)
100− where Coerce x = coerce x
101−
102{-# COMPLETE PatchMapWithMove #-}
69{-# COMPLETE PatchMapWithMove #-}
103pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
70pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
104−-- | Extract the representation of the 'PatchMapWithMove' as a map of
71+pattern PatchMapWithMove { unPatchMapWithMove } <- PatchMapWithMove' (PatchMapWithPatchingMove (coerce -> unPatchMapWithMove))
105−-- 'NodeInfo'.
106−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
107−pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
72+ where PatchMapWithMove m = PatchMapWithMove' $ PatchMapWithPatchingMove $ coerce m
108
73
109_PatchMapWithMove
74_PatchMapWithMove
110 :: Iso
75 :: Iso
@@ -135,9 +100,58 @@ instance TraversableWithIndex k (PatchMapWithMove k) where
135 itraversed <.
100 itraversed <.
136 traverse
101 traverse
137
102
103+newtype NodeInfo k v = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
104+ deriving ( Show, Read, Eq, Ord
105+ )
106+
107+{-# COMPLETE NodeInfo #-}
108+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
109+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } =
110+ NodeInfo' (PM.NodeInfo
111+ { PM._nodeInfo_to = _nodeInfo_to
112+ , PM._nodeInfo_from = _nodeInfo_from
113+ })
114+
115+_NodeInfo
116+ :: Iso
117+ (NodeInfo k0 v0)
118+ (NodeInfo k1 v1)
119+ (PM.NodeInfo k0 (Proxy v0))
120+ (PM.NodeInfo k1 (Proxy v1))
121+_NodeInfo = iso unNodeInfo' NodeInfo'
122+
123+instance Functor (NodeInfo k) where
124+ fmap f = runIdentity . traverse (Identity . f)
125+
126+instance Foldable (NodeInfo k) where
127+ foldMap = foldMapDefault
128+
129+instance Traversable (NodeInfo k) where
130+ traverse = _NodeInfo . traverseNodeInfo
131+ where
132+ traverseNodeInfo
133+ :: Traversal (PM.NodeInfo k (Proxy a)) (PM.NodeInfo k (Proxy b)) a b
134+ traverseNodeInfo = PM.bitraverseNodeInfo pure (\ ~Proxy -> pure Proxy)
135+
136+type From k v = PM.From k (Proxy v)
137+
138+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
139+
140+pattern From_Insert :: v -> From k v
141+pattern From_Insert v = PM.From_Insert v
142+
143+pattern From_Delete :: From k v
144+pattern From_Delete = PM.From_Delete
145+
146+pattern From_Move :: k -> From k v
147+pattern From_Move k = PM.From_Move k Proxy
148+
149+type To k = PM.To k
150+
151+
138-- | Create a 'PatchMapWithMove', validating it
152-- | Create a 'PatchMapWithMove', validating it
139patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
153patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
140−patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
154+patchMapWithMove = fmap coerce . PM.patchMapWithPatchingMove . coerce
141
155
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
156-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
157patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
@@ -160,8 +174,8 @@ moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
160-- @
174-- @
161-- let aMay = Map.lookup a map
175-- let aMay = Map.lookup a map
162-- bMay = Map.lookup b map
176-- bMay = Map.lookup b map
163−-- in maybe id (Map.insert a) (bMay <> aMay)
177+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
164−-- . maybe id (Map.insert b) (aMay <> bMay)
178+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
165-- . Map.delete a . Map.delete b $ map
179-- . Map.delete a . Map.delete b $ map
166-- @
180-- @
167swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
181swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
@@ -175,7 +189,7 @@ deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
175--
189--
176-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
190-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
191unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178−unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
192+unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
179
193
180-- | Apply the insertions, deletions, and moves to a given 'Map'
194-- | Apply the insertions, deletions, and moves to a given 'Map'
181instance Ord k => Patch (PatchMapWithMove k v) where
195instance Ord k => Patch (PatchMapWithMove k v) where
@@ -199,7 +213,7 @@ patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
213-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
200-- will produce a 'Map' with the same values as the second 'Map' but with the
214-- will produce a 'Map' with the same values as the second 'Map' but with the
201-- values sorted with the given ordering function.
215-- values sorted with the given ordering function.
202−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
216+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
217patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204 where newList = Map.toList newByIndexUnsorted
218 where newList = Map.toList newByIndexUnsorted
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
219 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
@@ -210,58 +224,9 @@ patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove
210patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
224patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
211 PM.patchThatChangesMap oldByIndex newByIndex
225 PM.patchThatChangesMap oldByIndex newByIndex
212
226
213−--
214−-- NodeInfo
215−--
216−
217−-- | Holds the information about each key: where its new value should come from,
218−-- and where its old value should go to
219−newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
220−
221−deriving instance (Show k, Show p) => Show (NodeInfo k p)
222−deriving instance (Read k, Read p) => Read (NodeInfo k p)
223−deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
224−deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
225−
226−{-# COMPLETE NodeInfo #-}
227−pattern NodeInfo :: To k -> From k v -> NodeInfo k v
228−_nodeInfo_to :: NodeInfo k v -> To k
229−_nodeInfo_from :: NodeInfo k v -> From k v
230−pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
231− PM.NodeInfo
232− { PM._nodeInfo_to = _nodeInfo_to
233− , PM._nodeInfo_from = Coerce _nodeInfo_from
234− }
235−
236−_NodeInfo
237− :: Iso
238− (NodeInfo k0 v0)
239− (NodeInfo k1 v1)
240− (PM.NodeInfo k0 (Proxy v0))
241− (PM.NodeInfo k1 (Proxy v1))
242−_NodeInfo = iso unNodeInfo' NodeInfo'
243−
244−instance Functor (NodeInfo k) where
245− fmap f = runIdentity . traverse (Identity . f)
246−
247−instance Foldable (NodeInfo k) where
248− foldMap = foldMapDefault
249−
250−instance Traversable (NodeInfo k) where
251− traverse = bitraverseNodeInfo pure
252−
253−bitraverseNodeInfo
254− :: Applicative f
255− => (k0 -> f k1)
256− -> (v0 -> f v1)
257− -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258−bitraverseNodeInfo fk fv = fmap NodeInfo'
259− . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260− . coerce
261−
262-- | Change the 'From' value of a 'NodeInfo'
227-- | Change the 'From' value of a 'NodeInfo'
263nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
228nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
264−nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
229+nodeInfoMapFrom = coerce . PM.nodeInfoMapFrom
265
230
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
231-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
267-- 'Applicative', 'Monad', etc.) action to get the new value
232-- 'Applicative', 'Monad', etc.) action to get the new value
@@ -269,44 +234,11 @@ nodeInfoMapMFrom
269 :: Functor f
234 :: Functor f
270 => (From k v -> f (From k v))
235 => (From k v -> f (From k v))
271 -> NodeInfo k v -> f (NodeInfo k v)
236 -> NodeInfo k v -> f (NodeInfo k v)
272−nodeInfoMapMFrom f = fmap NodeInfo'
237+nodeInfoMapMFrom f = fmap coerce . PM.nodeInfoMapMFrom f . coerce
273− . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274− . coerce
275
238
276-- | Set the 'To' field of a 'NodeInfo'
239-- | Set the 'To' field of a 'NodeInfo'
277nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
240nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
278nodeInfoSetTo = coerce . PM.nodeInfoSetTo
241nodeInfoSetTo = coerce . PM.nodeInfoSetTo
279
242
280−--
281−-- From
282−--
283−
284−-- | Describe how a key's new value should be produced
285−newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
286−
287−{-# COMPLETE From_Insert, From_Delete, From_Move #-}
288−
289−-- | Insert the given value here
290−pattern From_Insert :: v -> From k v
291−pattern From_Insert v = From' (PM.From_Insert v)
292−
293−-- | Delete the existing value, if any, from here
294−pattern From_Delete :: From k v
295−pattern From_Delete = From' PM.From_Delete
296−
297−-- | Move the value here from the given key
298−pattern From_Move :: k -> From k v
299−pattern From_Move k = From' (PM.From_Move k Proxy)
300−
301−bitraverseFrom
302− :: Applicative f
303− => (k0 -> f k1)
304− -> (v0 -> f v1)
305− -> From k0 v0 -> f (From k1 v1)
306−bitraverseFrom fk fv = fmap From'
307− . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308− . coerce
309−
310makeWrapped ''PatchMapWithMove
243makeWrapped ''PatchMapWithMove
311makeWrapped ''NodeInfo
244makeWrapped ''NodeInfo
312−makeWrapped ''From
src/Data/Patch/MapWithPatchingMove.hs+88−140
@@ -13,45 +13,14 @@
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
16+module Data.Patch.MapWithPatchingMove where
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
17
49import Data.Patch.Class
18import Data.Patch.Class
50
19
51−import Control.Lens hiding (from, to)
20+import Control.Arrow
52import Control.Lens.TH (makeWrapped)
21import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
22+import Control.Monad.Trans.State
54−import Data.Foldable (toList)
23+import Data.Foldable
55import Data.Function
24import Data.Function
56import Data.List
25import Data.List
57import Data.Map (Map)
26import Data.Map (Map)
@@ -61,9 +30,9 @@ import Data.Maybe
61import Data.Semigroup (Semigroup (..))
30import Data.Semigroup (Semigroup (..))
62#endif
31#endif
63import Data.Monoid.DecidablyEmpty
32import Data.Monoid.DecidablyEmpty
64−import Data.Set (Set)
65import qualified Data.Set as Set
33import qualified Data.Set as Set
66import Data.These (These (..))
34import Data.These (These (..))
35+import Data.Tuple
67
36
68-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
37-- | 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@,
38-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -86,6 +55,57 @@ deriving instance ( Ord k
86 , Patch p
55 , Patch p
87 ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
56 ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
88
57
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+
89-- | Create a 'PatchMapWithPatchingMove', validating it
109-- | Create a 'PatchMapWithPatchingMove', validating it
90patchMapWithPatchingMove
110patchMapWithPatchingMove
91 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
111 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
@@ -136,8 +156,8 @@ moveMapKey src dst
136-- @
156-- @
137-- let aMay = Map.lookup a map
157-- let aMay = Map.lookup a map
138-- bMay = Map.lookup b map
158-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
159+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
160+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
141-- . Map.delete a . Map.delete b $ map
161-- . Map.delete a . Map.delete b $ map
142-- @
162-- @
143swapMapKey
163swapMapKey
@@ -229,70 +249,39 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
229
249
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
250-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231-- will produce the second 'Map'.
251-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233patchThatChangesMap
252patchThatChangesMap
234− :: forall k p
235− . (Ord k, Ord (PatchTarget p), Monoid p)
253+ :: (Ord k, Ord (PatchTarget p), Monoid p)
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
254 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237patchThatChangesMap oldByIndex newByIndex = patch
255patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
256+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
257+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
258+ let f k v = do
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
259+ remainingValues <- get
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
260+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
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))
261+ then Map.delete v remainingValues
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
262+ else Map.insert v remainingKeys remainingValues
245− -- Generate patch info for a single value
263+ case Map.lookup v remainingValues of
246− -- Keys that are found in both the old and new sets will not be patched
264+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
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
265+ Just 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
266+ if k `Set.member` fromKs
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
267+ then do
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
268+ putRemainingKeys $ Set.delete k fromKs
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
269+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
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
270+ else do
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
271+ (fromK, remainingKeys) <- return $
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
272+ fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
273+ Set.minView fromKs -- There's an existing value, but it's not here; move it here
256− patchSingleValueThese v = \case
274+ putRemainingKeys remainingKeys
257− This oldKeys -> patchSingleValue v oldKeys mempty
275+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
258− That newKeys -> patchSingleValue v mempty newKeys
276+ Map.traverseWithKey f newByIndex
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
277+ unusedOldKeys = fold unusedValuesByValue
260− -- Generate froms and tos for all values, then merge them together
278+ pointlessMove k = \case
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
279+ From_Move k' _ | k == k' -> True
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
280+ _ -> False
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.
281+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
282+ then Just undefined
265− These from to -> NodeInfo from to
283+ else Nothing
266−
284+ 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
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
285
297-- | Change the 'From' value of a 'NodeInfo'
286-- | Change the 'From' value of a 'NodeInfo'
298nodeInfoMapFrom
287nodeInfoMapFrom
@@ -310,47 +299,6 @@ nodeInfoSetTo
310 :: To k -> NodeInfo k v -> NodeInfo k v
299 :: To k -> NodeInfo k v -> NodeInfo k v
311nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
300nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
312
301
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.
302-- | Helper data structure used for composing patches using the monoid instance.
355data Fixup k v
303data Fixup k v
356 = Fixup_Delete
304 = Fixup_Delete
src/Data/Semigroup/Additive.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
4−-- |
5−-- Module:
6−-- Data.Semigroup.Additive
7−-- Description:
8−-- This module defines a class for commutative semigroups, until it is moved
9−-- to another library.
10−module Data.Semigroup.Additive
11− ( Additive
12− ) where
13−
14−import Data.Functor.Const (Const (..))
15−import Data.Functor.Identity
16−import Data.Proxy
17−#if !MIN_VERSION_base(4,12,0)
18−-- for :*: and :.: semigroup instances
19−import Data.Orphans ()
20−#endif
21−#if !MIN_VERSION_base(4,11,0)
22−import Data.Semigroup (Semigroup (..))
23−#endif
24−import GHC.Generics
25−
26−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
27−class Semigroup q => Additive q where
28−
29−-- | Trivial additive semigroup.
30−instance Additive ()
31−
32−-- | Product additive semigroup.
33−-- A Pair of additive semigroups gives rise to a additive semigroup
34−instance (Additive a, Additive b) => Additive (a, b)
35−
36−-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
37−-- Base does not define Monoid (Compose f g a) so this is the best we can
38−-- really do for functor composition.
39−instance Additive (f (g a)) => Additive ((f :.: g) a)
40−
41−-- | Product of additive semigroups, Functor style.
42−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
43−
44−-- | Trivial additive semigroup, Functor style
45−instance Additive (Proxy x)
46−
47−-- | Const lifts additive semigroups into a functor.
48−instance Additive a => Additive (Const a x)
49−
50−-- | Identity lifts additive semigroups pointwise (at only one point)
51−instance Additive a => Additive (Identity a)
52−
53−-- | Functions lift additive semigroups pointwise.
54−instance Additive b => Additive (a -> b)
test/tests.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−module Main where
3−
4−import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)
5−import Data.Patch ( Patch(apply) )
6−import Data.Patch.MapWithMove ( patchThatChangesMap )
7−import Data.Map as Map ( Map, fromList, singleton )
8−import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))
9−import Hedgehog.Gen as Gen ( int )
10−import Hedgehog.Range as Range ( linear )
11−import Control.Monad (replicateM)
12−import System.Exit (exitFailure, exitSuccess)
13−import Data.Sequence as Seq ( foldMapWithIndex, replicateM )
14−
15−main :: IO ()
16−main = do
17− counts <- runTestTT $ test [
18− "Simple Move" ~: (do
19− let mapBefore = Map.fromList [(0,1)]
20− mapAfter = Map.fromList [(0,0),(1,1)]
21− patch = patchThatChangesMap mapBefore mapAfter
22− afterPatch = apply patch mapBefore
23− assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),
24− "Property Checks" ~: propertyChecks
25− ]
26− if errors counts + failures counts == 0 then exitSuccess else exitFailure
27−
28−propertyChecks :: IO Bool
29−propertyChecks = checkParallel $$(discover)
30−
31−prop_patchThatChangesMap :: Property
32−prop_patchThatChangesMap = property $ do
33− mapBefore <- makeRandomIntMap
34− mapAfter <- makeRandomIntMap
35− let patch = patchThatChangesMap mapBefore mapAfter
36− Just mapAfter === apply patch mapBefore
37−
38−makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)
39−makeRandomIntMap = do
40− let genNum = Gen.int (Range.linear 0 100)
41− length <- forAll genNum
42− listOfNumbers <- forAll $ Seq.replicateM length genNum
43− pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers