on develop help sign in
.github/workflows/haskell.yml+1−1
since splitsnapshots
unifiedsplit
@@ -42,6 +42,6 @@ jobs:
42 - name: Build
42 - name: Build
43 run: cabal build --enable-tests --enable-benchmarks all
43 run: cabal build --enable-tests --enable-benchmarks all
44 - name: Run tests
44 - name: Run tests
45− run: cabal test all
45+ run: cabal test --enable-tests all
46 - name: Build Docs
46 - name: Build Docs
47 run: cabal haddock
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
ChangeLog.md+14−10
@@ -2,9 +2,13 @@
2
2
3## Unreleased
3## Unreleased
4
4
5−* `PatchMapWithMove` supports moves with a patch.
5+* New dep of `data-orphans` for old GHC to get instances honestly instead of
6+ via `monoidal-containers`.
6
7
7−* `PatchDMapWithMove` supports moves with a patch.
8+## 0.0.5.0 - 2021-12-17
9+
10+* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
11+ from `Data.Patch` for compatability.
8
12
9* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
13* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
10 Care is taken to make this not a breaking change.
14 Care is taken to make this not a breaking change.
@@ -12,25 +16,25 @@
12 There are complete constructor and field patterns too, and everything is
16 There are complete constructor and field patterns too, and everything is
13 exported under the newtype as real constructors and fields would be.
17 exported under the newtype as real constructors and fields would be.
14
18
15−## 0.0.4.0
19+## 0.0.4.0 - 2021-04-20
16
20
17* Enable PolyKinds
21* Enable PolyKinds
18
22
19−## 0.0.3.2
23+## 0.0.3.2 - 2020-11-06
20
24
21* Update version bounds
25* Update version bounds
22
26
23−## 0.0.3.1
27+## 0.0.3.1 - 2020-02-05
24
28
25* Replace `fromJust` with something easier to debug.
29* Replace `fromJust` with something easier to debug.
26
30
27−## 0.0.3.0
31+## 0.0.3.0 - 2020-02-05
28
32
29* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
33* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
30
34
31* Create `DecidablyEmpty` subclass of `Monoid`.
35* Create `DecidablyEmpty` subclass of `Monoid`.
32
36
33−## 0.0.2.0
37+## 0.0.2.0 - 2020-01-17
34
38
35* Consistently provide:
39* Consistently provide:
36
40
@@ -42,16 +46,16 @@
42
46
43 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
47 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
44
48
45−## 0.0.1.0
49+## 0.0.1.0 - 2020-01-09
46
50
47* Support older GHCs with `split-these` flag.
51* Support older GHCs with `split-these` flag.
48
52
49* Additional instances for the `Group` class for basic types.
53* Additional instances for the `Group` class for basic types.
50
54
51−## 0.0.0.1
55+## 0.0.0.1 - 2020-01-08
52
56
53* Remove unneeded dependencies
57* Remove unneeded dependencies
54
58
55−## 0.0.0.0
59+## 0.0.0.0 - 2020-01-08
56
60
57* Extract patching functionality from Reflex.
61* Extract patching functionality from Reflex.
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+20−6
@@ -1,5 +1,5 @@
1Name: patch
1Name: patch
2−Version: 0.0.4.0
2+Version: 0.0.5.0
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.
@@ -41,33 +41,47 @@ 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.4
44+ , witherable >= 0.3 && < 0.5
45
45
46− exposed-modules: Control.Category.DecidablyEmpty
46+ if impl(ghc < 8.6) -- really, if base < 8.12
47+ build-depends: base-orphans >= 0.8 && < 0.9
48+
47− , Data.Functor.Misc
49+ exposed-modules: Data.Functor.Misc
48 , Data.Monoid.DecidablyEmpty
50 , Data.Monoid.DecidablyEmpty
49 , Data.Patch
51 , Data.Patch
50 , Data.Patch.Class
52 , Data.Patch.Class
51 , Data.Patch.DMap
53 , Data.Patch.DMap
52 , Data.Patch.DMapWithMove
54 , Data.Patch.DMapWithMove
53− , Data.Patch.DMapWithMove.By
54 , Data.Patch.IntMap
55 , Data.Patch.IntMap
55 , Data.Patch.Map
56 , Data.Patch.Map
56 , Data.Patch.MapWithMove
57 , Data.Patch.MapWithMove
57 , Data.Patch.MapWithPatchingMove
58 , Data.Patch.MapWithPatchingMove
59+ , Data.Semigroup.Additive
58
60
59 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
61 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
60 default-extensions: PolyKinds
62 default-extensions: PolyKinds
61
63
62 if flag(split-these)
64 if flag(split-these)
63 build-depends: these >= 1 && <1.2
65 build-depends: these >= 1 && <1.2
64− , these-lens >= 1 && <1.1
65 , semialign >=1 && <1.2
66 , semialign >=1 && <1.2
66 , monoidal-containers >= 0.6 && < 0.7
67 , monoidal-containers >= 0.6 && < 0.7
67 else
68 else
68 build-depends: these >= 0.4 && <0.9
69 build-depends: these >= 0.4 && <0.9
69 , monoidal-containers == 0.4.0.0
70 , monoidal-containers == 0.4.0.0
70
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+
71test-suite hlint
85test-suite hlint
72 default-language: Haskell2010
86 default-language: Haskell2010
73 type: exitcode-stdio-1.0
87 type: exitcode-stdio-1.0
src/Control/Category/DecidablyEmpty.hsdeleted−9
@@ -1,9 +0,0 @@
1−{-# LANGUAGE TypeOperators #-}
2−-- TODO upstream somwhere else?
3−module Control.Category.DecidablyEmpty where
4−
5−import Control.Category
6−import Data.Type.Equality
7−
8−class Category c => DecidablyEmpty c where
9− isId :: c a b -> Maybe (a :~: b)
src/Data/Functor/Misc.hs+5−28
@@ -1,6 +1,6 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveTraversable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
@@ -16,8 +16,6 @@
16module Data.Functor.Misc
16module Data.Functor.Misc
17 ( -- * Const2
17 ( -- * Const2
18 Const2 (..)
18 Const2 (..)
19− , Proxy3 (..)
20− , First2 (..)
21 , unConst2
19 , unConst2
22 , dmapToMap
20 , dmapToMap
23 , dmapToIntMap
21 , dmapToIntMap
@@ -38,7 +36,6 @@ module Data.Functor.Misc
38 , ComposeMaybe (..)
36 , ComposeMaybe (..)
39 ) where
37 ) where
40
38
41−import qualified Control.Category as Cat
42import Control.Applicative ((<$>))
39import Control.Applicative ((<$>))
43import Data.Dependent.Map (DMap)
40import Data.Dependent.Map (DMap)
44import qualified Data.Dependent.Map as DMap
41import qualified Data.Dependent.Map as DMap
@@ -50,7 +47,6 @@ import Data.IntMap (IntMap)
50import qualified Data.IntMap as IntMap
47import qualified Data.IntMap as IntMap
51import Data.Map (Map)
48import Data.Map (Map)
52import qualified Data.Map as Map
49import qualified Data.Map as Map
53−import qualified Data.Semigroupoid as Cat
54import Data.Some (Some, mkSome)
50import Data.Some (Some, mkSome)
55import Data.These
51import Data.These
56import Data.Type.Equality ((:~:)(Refl))
52import Data.Type.Equality ((:~:)(Refl))
@@ -66,15 +62,15 @@ data Const2 :: * -> x -> x -> * where
66 Const2 :: k -> Const2 k v v
62 Const2 :: k -> Const2 k v v
67 deriving (Typeable)
63 deriving (Typeable)
68
64
65+-- | Extract the value from a Const2
66+unConst2 :: Const2 k v v' -> k
67+unConst2 (Const2 k) = k
68+
69deriving instance Eq k => Eq (Const2 k v v')
69deriving instance Eq k => Eq (Const2 k v v')
70deriving instance Ord k => Ord (Const2 k v v')
70deriving instance Ord k => Ord (Const2 k v v')
71deriving instance Show k => Show (Const2 k v v')
71deriving instance Show k => Show (Const2 k v v')
72deriving instance Read k => Read (Const2 k v v)
72deriving instance Read k => Read (Const2 k v v)
73
73
74−-- | Extract the value from a Const2
75−unConst2 :: Const2 k v v' -> k
76−unConst2 (Const2 k) = k
77−
78instance Show k => GShow (Const2 k v) where
74instance Show k => GShow (Const2 k v) where
79 gshowsPrec n x@(Const2 _) = showsPrec n x
75 gshowsPrec n x@(Const2 _) = showsPrec n x
80
76
@@ -90,25 +86,6 @@ instance Ord k => GCompare (Const2 k v) where
90 EQ -> GEQ
86 EQ -> GEQ
91 GT -> GGT
87 GT -> GGT
92
88
93−data Proxy3 :: x -> y -> z -> * where
94− Proxy3 :: Proxy3 vx vy vz
95− deriving ( Show, Read, Eq, Ord
96− , Functor, Foldable, Traversable
97− , Typeable
98− )
99−
100−instance Cat.Category (Proxy3 x) where
101− id = Proxy3
102− ~Proxy3 . ~Proxy3 = Proxy3
103−
104−newtype First2 (t :: k -> *) (a :: k) (b :: k) = First2 (t b)
105− deriving ( Show, Read, Eq, Ord
106− , Functor, Foldable, Traversable
107− )
108−
109−instance Cat.Semigroupoid (First2 x) where
110− First2 x `o` ~(First2 _) = First2 x
111−
112-- | Convert a 'DMap' to a regular 'Map'
89-- | Convert a 'DMap' to a regular 'Map'
113dmapToMap :: DMap (Const2 k v) Identity -> Map k v
90dmapToMap :: DMap (Const2 k v) Identity -> Map k v
114dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
91dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
src/Data/Patch.hs+9−22
@@ -23,11 +23,12 @@ 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
29 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
30 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
30− , patchDMapWithMoveToPatchMapWithPatchingMoveWith
31+ , patchDMapWithMoveToPatchMapWithMoveWith
31 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
32 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
32 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
33 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
33 )
34 )
@@ -45,34 +46,25 @@ class (Semigroup q, Monoid q) => Group q where
45 (~~) :: q -> q -> q
46 (~~) :: q -> q -> q
46 r ~~ s = r <> negateG s
47 r ~~ s = r <> negateG s
47
48
48−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
49−class Semigroup q => Additive q where
50−
51-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
49-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
52newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
50newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
53
51
54−instance Additive p => PatchHet (AdditivePatch p) where
55− type PatchSource (AdditivePatch p) = p
56− type PatchTarget (AdditivePatch p) = p
57instance Additive p => Patch (AdditivePatch p) where
52instance Additive p => Patch (AdditivePatch p) where
53+ type PatchTarget (AdditivePatch p) = p
58 apply (AdditivePatch p) q = Just $ p <> q
54 apply (AdditivePatch p) q = Just $ p <> q
59
55
60instance (Ord k, Group q) => Group (MonoidalMap k q) where
56instance (Ord k, Group q) => Group (MonoidalMap k q) where
61 negateG = fmap negateG
57 negateG = fmap negateG
62
58
63−instance (Ord k, Additive q) => Additive (MonoidalMap k q)
64−
65-- | Trivial group.
59-- | Trivial group.
66instance Group () where
60instance Group () where
67− negateG ~() = ()
61+ negateG _ = ()
68− ~() ~~ ~() = ()
62+ _ ~~ _ = ()
69−instance Additive ()
70
63
71-- | Product group. A Pair of groups gives rise to a group
64-- | Product group. A Pair of groups gives rise to a group
72instance (Group a, Group b) => Group (a, b) where
65instance (Group a, Group b) => Group (a, b) where
73 negateG (a, b) = (negateG a, negateG b)
66 negateG (a, b) = (negateG a, negateG b)
74 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
67 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
75−instance (Additive a, Additive b) => Additive (a, b)
76
68
77-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
69-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
78-- Base does not define Monoid (Compose f g a) so this is the best we can
70-- Base does not define Monoid (Compose f g a) so this is the best we can
@@ -80,29 +72,24 @@ instance (Additive a, Additive b) => Additive (a, b)
80instance Group (f (g a)) => Group ((f :.: g) a) where
72instance Group (f (g a)) => Group ((f :.: g) a) where
81 negateG (Comp1 xs) = Comp1 (negateG xs)
73 negateG (Comp1 xs) = Comp1 (negateG xs)
82 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
74 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
83−instance Additive (f (g a)) => Additive ((f :.: g) a)
84
75
85-- | Product of groups, Functor style.
76-- | Product of groups, Functor style.
86instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
77instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
87 negateG (a :*: b) = negateG a :*: negateG b
78 negateG (a :*: b) = negateG a :*: negateG b
88 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
79 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
89−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
90
80
91-- | Trivial group, Functor style
81-- | Trivial group, Functor style
92instance Group (Proxy x) where
82instance Group (Proxy x) where
93− negateG ~Proxy = Proxy
83+ negateG _ = Proxy
94− ~Proxy ~~ ~Proxy = Proxy
84+ _ ~~ _ = Proxy
95−instance Additive (Proxy x)
96
85
97-- | Const lifts groups into a functor.
86-- | Const lifts groups into a functor.
98deriving instance Group a => Group (Const a x)
87deriving instance Group a => Group (Const a x)
99−instance Additive a => Additive (Const a x)
88+
100−-- | Ideitnty lifts groups pointwise (at only one point)
89+-- | Identity lifts groups pointwise (at only one point)
101deriving instance Group a => Group (Identity a)
90deriving instance Group a => Group (Identity a)
102−instance Additive a => Additive (Identity a)
103
91
104-- | Functions lift groups pointwise.
92-- | Functions lift groups pointwise.
105instance Group b => Group (a -> b) where
93instance Group b => Group (a -> b) where
106 negateG f = negateG . f
94 negateG f = negateG . f
107 (~~) = liftA2 (~~)
95 (~~) = liftA2 (~~)
108−instance Additive b => Additive (a -> b)
src/Data/Patch/Class.hs+5−131
@@ -1,58 +1,23 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE DerivingStrategies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11-- | The interface for types which represent changes made to other types
4-- | The interface for types which represent changes made to other types
12module Data.Patch.Class where
5module Data.Patch.Class where
13
6
14−import qualified Data.Semigroupoid as Cat
15import Data.Functor.Identity
7import Data.Functor.Identity
16−import Data.Functor.Misc
17import Data.Kind (Type)
8import Data.Kind (Type)
18import Data.Maybe
9import Data.Maybe
19#if !MIN_VERSION_base(4,11,0)
10#if !MIN_VERSION_base(4,11,0)
20import Data.Semigroup (Semigroup(..))
11import Data.Semigroup (Semigroup(..))
21#endif
12#endif
22import Data.Proxy
13import Data.Proxy
23−import Data.Type.Equality ((:~:) (..))
24−
25−class PatchHet p where
26− type PatchSource p :: Type
27− type PatchTarget p :: Type
28− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
29− -- 'Nothing'.
30− applyHet
31− :: p
32− -> PatchSource p
33− -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
34− default applyHet
35− :: Patch p
36− => p
37− -> PatchSource p
38− -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
39− applyHet p a = case apply p a of
40− Nothing -> Left Refl
41− Just a' -> Right a'
42−
43−-- | Apply a 'PatchHet'; if it does nothing, return the original value
44−applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
45−applyAlwaysHet p t = case applyHet p t of
46− Left Refl -> t
47− Right t' -> t'
48
14
49-- | A 'Patch' type represents a kind of change made to a datastructure.
15-- | A 'Patch' type represents a kind of change made to a datastructure.
50--
16--
51-- 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
52-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
18-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
53−class ( PatchHet p
54− , PatchSource p ~ PatchTarget p
55− ) => Patch p where
19+class Patch p where
20+ type PatchTarget p :: Type
56 -- | 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
57 -- 'Nothing'.
22 -- 'Nothing'.
58 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
23 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -62,110 +27,19 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
62applyAlways p t = fromMaybe t $ apply p t
27applyAlways p t = fromMaybe t $ apply p t
63
28
64-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
29-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
65−instance PatchHet (Identity a) where
66− type PatchSource (Identity a) = a
67− type PatchTarget (Identity a) = a
68instance Patch (Identity a) where
30instance Patch (Identity a) where
31+ type PatchTarget (Identity a) = a
69 apply (Identity a) _ = Just a
32 apply (Identity a) _ = Just a
70
33
71-- | 'Proxy' can be used as a 'Patch' that does nothing.
34-- | 'Proxy' can be used as a 'Patch' that does nothing.
72−instance forall (a :: Type). PatchHet (Proxy a) where
73− type PatchSource (Proxy a) = a
74− type PatchTarget (Proxy a) = a
75instance forall (a :: Type). Patch (Proxy a) where
35instance forall (a :: Type). Patch (Proxy a) where
36+ type PatchTarget (Proxy a) = a
76 apply ~Proxy _ = Nothing
37 apply ~Proxy _ = Nothing
77
38
78-- | Like '(.)', but composes functions that return patches rather than
39-- | Like '(.)', but composes functions that return patches rather than
79-- functions that return new values. The Semigroup instance for patches must
40-- functions that return new values. The Semigroup instance for patches must
80-- apply patches right-to-left, like '(.)'.
41-- apply patches right-to-left, like '(.)'.
81−composePatchFunctions
42+composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
82− :: (Patch p, Semigroup p)
83− => (PatchTarget p -> p)
84− -> (PatchTarget p -> p)
85− -> PatchTarget p -> p
86composePatchFunctions g f a =
43composePatchFunctions g f a =
87 let fp = f a
44 let fp = f a
88 in g (applyAlways fp a) <> fp
45 in g (applyAlways fp a) <> fp
89−
90−
91−class PatchHet2Base (p :: k -> k -> *) where
92− type PatchSource1 p :: k -> *
93− type PatchTarget1 p :: k -> *
94−
95−class ( PatchHet2Base p
96− , PatchHet (p from to)
97− , PatchSource1 p from ~ PatchSource (p from to)
98− , PatchTarget1 p to ~ PatchTarget (p from to)
99− ) => PatchHet2Locally (p :: k -> k -> *) from to where
100−instance ( PatchHet2Base p
101− , PatchHet (p from to)
102− , PatchSource1 p from ~ PatchSource (p from to)
103− , PatchTarget1 p to ~ PatchTarget (p from to)
104− ) => PatchHet2Locally (p :: k -> k -> *) from to where
105−
106−applyHet2Locally
107− :: PatchHet2Locally p from to
108− => p from to
109− -> PatchSource1 p from
110− -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
111−applyHet2Locally = applyHet
112−
113−applyAlwaysHet2Locally
114− :: PatchHet2Locally p from to
115− => p from to
116− -> PatchSource1 p from
117− -> PatchTarget1 p to
118−applyAlwaysHet2Locally = applyAlwaysHet
119−
120−-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
121−-- PatchHet2Locally, or at least get rid of this.
122−class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where
123− applyHet2
124− :: p from to
125− -> PatchSource1 p from
126− -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
127−
128−applyAlwaysHet2
129− :: PatchHet2 p
130− => p from to
131− -> PatchSource1 p from
132− -> PatchTarget1 p to
133−applyAlwaysHet2 p t = case applyHet2 p t of
134− Left Refl -> t
135− Right t' -> t'
136−
137−-- | Connect the classes without quanitified constraints
138−newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
139− deriving newtype Cat.Semigroupoid
140−
141−instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
142− type PatchSource (ProjectLocal p from to) = PatchSource1 p from
143− type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
144− applyHet (ProjectLocal p) = applyHet2 p
145−
146−instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
147− type PatchSource1 (ProjectLocal p) = PatchSource1 p
148− type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
149−
150−class ( PatchHet2Base p
151− , PatchSource1 p ~ PatchTarget1 p
152− ) => Patch2 p
153−instance ( PatchHet2Base p
154− , PatchSource1 p ~ PatchTarget1 p
155− ) => Patch2 p
156−
157−-- | 'First2' can be used as a 'Patch' that always fully replaces the value
158−instance PatchHet (First2 (t :: k -> *) (from :: k) (to :: k)) where
159− type PatchSource (First2 t from to) = t from
160− type PatchTarget (First2 t from to) = t to
161− applyHet (First2 val) _ = Right val
162−
163−-- | 'Proxy3' can be used as a 'Patch' that always does nothing
164−instance PatchHet (Proxy3 (t :: k -> *) (a :: k) (a :: k)) where
165− type PatchSource (Proxy3 t a a) = t a
166− type PatchTarget (Proxy3 t a a) = t a
167− applyHet ~Proxy3 _ = Left Refl
168−
169−instance PatchHet2Base (Proxy3 (t :: k -> *) :: k -> k -> *) where
170− type PatchSource1 (Proxy3 t) = t
171− type PatchTarget1 (Proxy3 t) = t
src/Data/Patch/DMap.hs+1−3
@@ -42,10 +42,8 @@ instance GCompare k => DecidablyEmpty (PatchDMap k v) where
42 isEmpty (PatchDMap m) = DMap.null m
42 isEmpty (PatchDMap m) = DMap.null m
43
43
44-- | Apply the insertions or deletions to a given 'DMap'.
44-- | Apply the insertions or deletions to a given 'DMap'.
45−instance GCompare k => PatchHet (PatchDMap k v) where
46− type PatchSource (PatchDMap k v) = DMap k v
47− type PatchTarget (PatchDMap k v) = DMap k v
48instance GCompare k => Patch (PatchDMap k v) where
45instance GCompare k => Patch (PatchDMap k v) where
46+ type PatchTarget (PatchDMap k v) = DMap k v
49 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
47 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
50 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
48 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
51 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
49 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
src/Data/Patch/DMapWithMove.hs+161−419
@@ -1,234 +1,108 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE InstanceSigs #-}
7{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE PatternGuards #-}
10{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE Rank2Types #-}
9{-# LANGUAGE Rank2Types #-}
12{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
16−{-# LANGUAGE UndecidableSuperClasses #-}
17
13
18-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
19-- move values between keys.
15-- move values between keys.
20module Data.Patch.DMapWithMove where
16module Data.Patch.DMapWithMove where
21
17
22−import qualified Control.Category as Cat
18+import Data.Patch.Class
23−--import qualified Control.Category.DecidablyEmpty as Cat
19+import Data.Patch.MapWithMove (PatchMapWithMove (..))
20+import qualified Data.Patch.MapWithMove as MapWithMove
24
21
25−import Data.Constraint.Extras (Has')
22+import Data.Constraint.Extras
26import Data.Dependent.Map (DMap)
23import Data.Dependent.Map (DMap)
27import Data.Dependent.Sum (DSum (..))
24import Data.Dependent.Sum (DSum (..))
28import qualified Data.Dependent.Map as DMap
25import qualified Data.Dependent.Map as DMap
29−import Data.Functor.Constant (Constant (..))
26+import Data.Functor.Constant
30import Data.Functor.Misc
27import Data.Functor.Misc
31− ( Const2 (..), Proxy3 (..)
32− , weakenDMapWith
33− , dmapToMapWith
34− )
35−import Data.Functor.Product (Product (..))
28+import Data.Functor.Product
36import Data.GADT.Compare (GEq (..), GCompare (..))
29import Data.GADT.Compare (GEq (..), GCompare (..))
37−import Data.GADT.Show (GRead, GShow, gshow)
30+import Data.GADT.Show (GShow, gshow)
38import qualified Data.Map as Map
31import qualified Data.Map as Map
39import Data.Maybe
32import Data.Maybe
40import Data.Monoid.DecidablyEmpty
33import Data.Monoid.DecidablyEmpty
41−import Data.Semigroupoid as Cat
42#if !MIN_VERSION_base(4,11,0)
34#if !MIN_VERSION_base(4,11,0)
43−import Data.Semigroup (Semigroup (..), (<>))
35+import Data.Semigroup (Semigroup (..))
44#endif
36#endif
45import Data.Some (Some, mkSome)
37import Data.Some (Some, mkSome)
46−import Data.Proxy (Proxy (..))
38+import Data.These
47−import Data.These (These (..))
48
39
49−import Data.Patch.Class
50− ( Patch (..), PatchHet (..)
51− , PatchHet2 (..), PatchSource1, PatchTarget1
52− , applyAlwaysHet2
53− )
54−import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove (..))
55−import qualified Data.Patch.MapWithPatchingMove as MapWithPatchingMove
56−
57−-- | Like 'PatchMapWithPatchingMove', but for 'DMap'. Each key carries a 'NodeInfo'
58−-- which describes how it will be changed by the patch and connects move sources
40+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
59−-- and destinations.
41+-- destinations.
60--
42--
61-- Invariants:
43-- Invariants:
62--
44--
63−-- * A key should not move to itself.
45+-- * A key should not move to itself.
64−--
65−-- * A move should always be represented with both the destination key (as a
46+-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
66−-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
67−-- destination)@)
68newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
47newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
69
48
70−--deriving instance ( GShow k
71−-- , HasZip Show k p
72−-- , Has' Show k (PatchTarget1 p)
73−-- ) => Show (PatchDMapWithMove k p)
74−--deriving instance ( GRead k
75−-- , HasZip Read k p
76−-- , Has' Read k (PatchTarget1 p)
77−-- ) => Read (PatchDMapWithMove k p)
78−--deriving instance ( GEq k
79−-- , HasZip Eq k p
80−-- , Has' Eq k (PatchTarget1 p)
81−-- ) => Eq (PatchDMapWithMove k p)
82−--deriving instance ( GCompare k
83−-- , HasZip Ord k p
84−-- , Has' Ord k (PatchTarget1 p)
85−-- ) => Ord (PatchDMapWithMove k p)
86−
87-- It won't let me derive for some reason
49-- It won't let me derive for some reason
88−instance ( GCompare k
89− , Cat.Semigroupoid v
90− , PatchHet2 v
91− , PatchSource1 v ~ PatchTarget1 v
92− ) => DecidablyEmpty (PatchDMapWithMove k v) where
50+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
93 isEmpty (PatchDMapWithMove m) = DMap.null m
51 isEmpty (PatchDMapWithMove m) = DMap.null m
94
52
95−-- | Structure which represents what changes apply to a particular key.
96−-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
53+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
97−-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
54+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
98−-- key the current key is moving to if involved in a move.
99−data NodeInfo k p a = NodeInfo
55+data NodeInfo k v a = NodeInfo
100− { _nodeInfo_from :: !(From k p a)
56+ { _nodeInfo_from :: !(From k v a)
101− -- ^ Change applying to the current key, be it an insert, move, or delete.
57+ -- ^Change applying to the current key, be it an insert, move, or delete.
102− , _nodeInfo_to :: !(To k p a)
58+ , _nodeInfo_to :: !(To k a)
103− -- ^ Where this key is moving to, if involved in a move. Should only be
59+ -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
104− -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
105 }
60 }
106−
107−--deriving instance ( Show (k a)
61+ deriving (Show)
108−-- , Show (p a a)
62+
109−-- , Show (PatchTarget1 p a)
110−-- ) => Show (NodeInfo k p a)
111−--deriving instance ( Read (k a)
112−-- , Read (p a a)
113−-- , Read (PatchTarget1 p a)
114−-- ) => Read (NodeInfo k p a)
115−--deriving instance ( Eq (k a)
116−-- , Eq (p a a)
117−-- , Eq (PatchTarget1 p a)
118−-- ) => Eq (NodeInfo k p a)
119−--deriving instance ( Ord (k a)
120−-- , Ord (p a a)
121−-- , Ord (PatchTarget1 p a)
122−-- ) => Ord (NodeInfo k p a)
123−
124−-- | Structure describing a particular change to a key, be it inserting a new
63+-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
125−-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
126−-- a key (@From_Delete@), or moving a key (@From_Move@).
64+-- key (@From_Delete@), or moving a key (@From_Move@).
127−--
128−-- This type isn't used directly as the from field patch, but is instead wrapped
129−-- in an existential. However, it is nice to be able to reason about this in
130−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
131−data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
65+data From (k :: a -> *) (v :: a -> *) :: a -> * where
132− -- | Insert a new or update an existing key with the given value @PatchTarget1
66+ -- |Insert a new or update an existing key with the given value @v a@
133− -- p a@
134− From_Insert :: PatchTarget1 p to -> From k p to
67+ From_Insert :: v a -> From k v a
135− -- | Delete the existing key
68+ -- |Delete the existing key
136− From_Delete :: From k p to
69+ From_Delete :: From k v a
137− -- | Move the value from the given key @k a@ to this key. The source key
138− -- should also have an entry in the patch giving the current key as
70+ -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
139− -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
71+ -- usually but not necessarily with @From_Delete@.
140− From_Move :: !(DSum k (Flip p to)) -> From k p to
72+ From_Move :: !(k a) -> From k v a
141−
73+ deriving (Show, Read, Eq, Ord)
142−deriving instance ( Show (k a), GShow k
74+
143− , Has' Show k (Flip p a)
75+-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
144− , Show (PatchTarget1 p a)
76+-- operation.
145− ) => Show (From k p a)
77+type To = ComposeMaybe
146−deriving instance ( Read (k a), GRead k
147− , Has' Read k (Flip p a)
148− , Read (PatchTarget1 p a)
149− ) => Read (From k p a)
150−deriving instance ( GEq k
151− , Has' Eq k (Flip p a)
152− , Eq (PatchTarget1 p a)
153− ) => Eq (From k p a)
154−deriving instance ( GCompare k
155− , Has' Eq k (Flip p a) -- superclass bug
156− , Has' Ord k (Flip p a)
157− , Ord (PatchTarget1 p a)
158− ) => Ord (From k p a)
159−
160−newtype Flip p to from = Flip (p from to)
161−
162−instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
163− id = Flip Cat.id
164− Flip y . Flip x = Flip $ x Cat.. y
165−
166−-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
167−-- is, we store just the information necessary to compose a @To@ and @From@ like
168−-- @oLocal@ composes two @From@s.
169−data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
170− -- | Delete or leave in place
171− To_NonMove :: To k p from
172− -- | Move the value from the given key @k a@ to this key. The target key
173− -- should also have an entry in the patch giving the current key in
174− -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
175− To_Move :: !(DSum k (p from)) -> To k p from
176−
177−deriving instance ( Show (k a), GShow k
178− , Has' Show k (p a)
179− , Show (PatchTarget1 p a)
180− ) => Show (To k p a)
181−deriving instance ( Read (k a), GRead k
182− , Has' Read k (p a)
183− , Read (PatchTarget1 p a)
184− ) => Read (To k p a)
185−deriving instance ( GEq k
186− , Has' Eq k (p a)
187− , Eq (PatchTarget1 p a)
188− ) => Eq (To k p a)
189−deriving instance ( GCompare k
190− , Has' Eq k (p a) -- superclass bug
191− , Has' Ord k (p a)
192− , Ord (PatchTarget1 p a)
193− ) => Ord (To k p a)
194
78
195-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
79-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
196−validPatchDMapWithMove
80+validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
197− :: forall k v
198− . (GCompare k, GShow k)
199− => DMap k (NodeInfo k v)
200− -> Bool
201validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
81validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
202
82
203-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
83-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
204−validationErrorsForPatchDMapWithMove
84+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
205− :: forall k v
206− . (GCompare k, GShow k)
207− => DMap k (NodeInfo k v)
208− -> [String]
209validationErrorsForPatchDMapWithMove m =
85validationErrorsForPatchDMapWithMove m =
210 noSelfMoves <> movesBalanced
86 noSelfMoves <> movesBalanced
211 where
87 where
212 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
88 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
213− selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
214− | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
89+ selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
215− selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
216− | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
90+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
217 selfMove _ = Nothing
91 selfMove _ = Nothing
218 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
92 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
219− unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
93+ unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
220 case DMap.lookup src m of
94 case DMap.lookup src m of
221 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
95 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
222− Just (NodeInfo _ (To_Move (dst' :=> _))) ->
96+ Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
223 if isNothing (dst' `geq` dst)
97 if isNothing (dst' `geq` dst)
224 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
98 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
225 else Nothing
99 else Nothing
226 _ ->
100 _ ->
227 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
101 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
228− unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
102+ unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
229 case DMap.lookup dst m of
103 case DMap.lookup dst m of
230 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
104 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
231− Just (NodeInfo (From_Move (src' :=> _)) _) ->
105+ Just (NodeInfo (From_Move src') _) ->
232 if isNothing (src' `geq` src)
106 if isNothing (src' `geq` src)
233 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
107 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
234 else Nothing
108 else Nothing
@@ -237,49 +111,35 @@ validationErrorsForPatchDMapWithMove m =
237 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
111 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
238 unbalancedMove _ = Nothing
112 unbalancedMove _ = Nothing
239
113
114+-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
115+instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
116+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
117+
240-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
118-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
241data Pair1 f g a = Pair1 (f a) (g a)
119data Pair1 f g a = Pair1 (f a) (g a)
242
120
243-- |Helper data structure used for composing patches using the monoid instance.
121-- |Helper data structure used for composing patches using the monoid instance.
244−data Fixup k p a
122+data Fixup k v a
245 = Fixup_Delete
123 = Fixup_Delete
246− | Fixup_Update (These (From k p a) (To k p a))
124+ | Fixup_Update (These (From k v a) (To k a))
247−
125+
248−-- | Compose patches having the same effect as applying the patches in turn:
126+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
249−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
250−instance ( GCompare k
251− , Cat.Semigroupoid p
252− -- , Cat.DecidablyEmpty p
253− , PatchHet2 p
254− , PatchSource1 p ~ PatchTarget1 p
255− ) => Semigroup (PatchDMapWithMove k p) where
127+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
256 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
128 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
257 where
129 where
258− connections :: [DSum k (Pair1 (To k p) (From k p))]
259− connections = DMap.toList $ DMap.intersectionWithKey
260− (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
130+ connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
261− ma
262− mb
263− h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
131+ h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
264− h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
132+ h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
265− (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
133+ (Just toAfter, From_Move fromBefore)
266− --case toAfter `geq` fromBefore of
134+ | isJust $ fromBefore `geq` toAfter
267− -- Just Refl | Just Refl <- Cat.isId p0 ->
268− -- [ toAfter :=> Fixup_Delete ]
135+ -> [toAfter :=> Fixup_Delete]
269− -- _ ->
136+ | otherwise
270− [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
137+ -> [ toAfter :=> Fixup_Update (This editBefore)
271− , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
138+ , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
272− ]
139+ ]
273− (To_NonMove, From_Move (fromBefore :=> _)) ->
274− -- The item is destroyed in the second patch, so indicate that it is
140+ (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
275− -- destroyed in the source map
276− [fromBefore :=> Fixup_Update (That To_NonMove)]
277− (To_Move (toAfter :=> p), From_Insert val) ->
278− [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
279− (To_Move (toAfter :=> _), From_Delete) ->
280− [toAfter :=> Fixup_Update (This From_Delete)]
141+ (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
281− (To_NonMove, _) ->
142+ (Nothing, _) -> []
282− []
283 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
143 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
284 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
144 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
285 | This x <- a, That y <- b
145 | This x <- a, That y <- b
@@ -310,19 +170,13 @@ instance ( GCompare k
310 These _ b -> Just b
170 These _ b -> Just b
311 That b -> Just b
171 That b -> Just b
312
172
313−-- | Compose patches having the same effect as applying the patches in turn:
173+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
314−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
315−instance ( GCompare k
316− , Cat.Semigroupoid p
317− -- , DecidablyEmpty p
318− , PatchHet2 p
319− , PatchSource1 p ~ PatchTarget1 p
320− ) => Monoid (PatchDMapWithMove k p) where
174+instance GCompare k => Monoid (PatchDMapWithMove k v) where
321 mempty = PatchDMapWithMove mempty
175 mempty = PatchDMapWithMove mempty
322 mappend = (<>)
176 mappend = (<>)
323
177
324{-
178{-
325−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
179+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
326PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
180PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
327 where
181 where
328 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
182 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
@@ -343,31 +197,25 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
343 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
344-}
198-}
345
199
346−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
200+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
347−-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
348−-- 'DMap.insert'.
349−insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
201+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
350insertDMapKey k v =
202insertDMapKey k v =
351− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
203+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
352
204
353−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value
205+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
354−-- from the first key @k a@ to the second key @k a@, equivalent to:
355--
206--
356-- @
207-- @
357-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
208-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
358-- @
209-- @
359−moveDMapKey
360− :: GCompare k
361− => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
210+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
362moveDMapKey src dst = case src `geq` dst of
211moveDMapKey src dst = case src `geq` dst of
363 Nothing -> PatchDMapWithMove $ DMap.fromList
212 Nothing -> PatchDMapWithMove $ DMap.fromList
364− [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
213+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
365− , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
214+ , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
366 ]
215 ]
367− Just _ -> PatchDMapWithMove DMap.empty
216+ Just _ -> mempty
368
217
369−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
218+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
370−-- in the mapping, equivalent to:
371--
219--
372-- @
220-- @
373-- let aMay = DMap.lookup a dmap
221-- let aMay = DMap.lookup a dmap
@@ -376,18 +224,17 @@ moveDMapKey src dst = case src `geq` dst of
376-- . maybe id (DMap.insert b) (aMay <> bMay)
224-- . maybe id (DMap.insert b) (aMay <> bMay)
377-- . DMap.delete a . DMap.delete b $ dmap
225-- . DMap.delete a . DMap.delete b $ dmap
378-- @
226-- @
379−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
227+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
380swapDMapKey src dst = case src `geq` dst of
228swapDMapKey src dst = case src `geq` dst of
381 Nothing -> PatchDMapWithMove $ DMap.fromList
229 Nothing -> PatchDMapWithMove $ DMap.fromList
382− [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
230+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
383− , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
231+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
384 ]
232 ]
385− Just _ -> PatchDMapWithMove DMap.empty
233+ Just _ -> mempty
386
234
387−-- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
235+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
388−-- the mapping, equivalent to 'DMap.delete'.
389deleteDMapKey :: k a -> PatchDMapWithMove k v
236deleteDMapKey :: k a -> PatchDMapWithMove k v
390−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
237+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
391
238
392{-
239{-
393k1, k2 :: Const2 Int () ()
240k1, k2 :: Const2 Int () ()
@@ -413,217 +260,112 @@ dst (PatchDMapWithMove x _) = x
413src (PatchDMapWithMove _ x) = x
260src (PatchDMapWithMove _ x) = x
414-}
261-}
415
262
416−-- | Extract the 'DMap' representing the patch changes from the
263+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
417−-- 'PatchDMapWithMove'.
418unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
264unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
419unPatchDMapWithMove (PatchDMapWithMove p) = p
265unPatchDMapWithMove (PatchDMapWithMove p) = p
420
266
421−-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
267+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
422−-- without checking any invariants.
423--
268--
424-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
269-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
425unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
270unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
426unsafePatchDMapWithMove = PatchDMapWithMove
271unsafePatchDMapWithMove = PatchDMapWithMove
427
272
428−-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while
429−-- checking invariants. If the invariants are satisfied, @Right p@ is returned
273+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
430-- otherwise @Left errors@.
274-- otherwise @Left errors@.
431−patchDMapWithPatchingMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
275+patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
432−patchDMapWithPatchingMove dm =
276+patchDMapWithMove dm =
433 case validationErrorsForPatchDMapWithMove dm of
277 case validationErrorsForPatchDMapWithMove dm of
434 [] -> Right $ unsafePatchDMapWithMove dm
278 [] -> Right $ unsafePatchDMapWithMove dm
435 errs -> Left errs
279 errs -> Left errs
436
280
437−-- | Map a natural transform @v -> v'@ over the given patch, transforming
281+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
438−-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
439−mapPatchDMapWithMove
282+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
440− :: forall k p p'
441− . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
442− -> (forall from to. p from to -> p' from to)
443− -> PatchDMapWithMove k p
444− -> PatchDMapWithMove k p'
445−mapPatchDMapWithMove f g (PatchDMapWithMove m) =
283+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
446− PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
447− { _nodeInfo_from = h $ _nodeInfo_from ni
284+ DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
448− , _nodeInfo_to = j $ _nodeInfo_to ni
449− }) m
450− where h :: forall a. From k p a -> From k p' a
285+ where g :: forall a. From k v a -> From k v' a
451− h = \case
286+ g = \case
452 From_Insert v -> From_Insert $ f v
287 From_Insert v -> From_Insert $ f v
453 From_Delete -> From_Delete
288 From_Delete -> From_Delete
454− From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
289+ From_Move k -> From_Move k
455− j :: forall a. To k p a -> To k p' a
290+
456− j = \case
457− To_NonMove -> To_NonMove
458− To_Move (k :=> p) -> To_Move $ k :=> g p
459−
460−-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
461−-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
291+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
462−-- ('PatchDMapWithMove' k v')@.
463−traversePatchDMapWithMove
292+traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
464− :: forall m k p p'
465− . Applicative m
466− => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
467− -> (forall from to. p from to -> m (p' from to))
468− -> PatchDMapWithMove k p
469− -> m (PatchDMapWithMove k p')
470−traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
293+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
471− (\_ -> f)
294+
472− (\_ _ -> g)
473−
474−-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
475−-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
295+-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
476−-- ('PatchDMapWithMove' k v')@.
477−traversePatchDMapWithMoveWithKey
296+traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
478− :: forall m k p p'
479− . Applicative m
480− => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
481− -> (forall from to. k from -> k to -> p from to -> m (p' from to))
482− -> PatchDMapWithMove k p
483− -> m (PatchDMapWithMove k p')
484−traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
297+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
485− PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
486− <$> h k (_nodeInfo_from ni)
487− <*> j k (_nodeInfo_to ni)) m
488− where h :: forall a. k a -> From k p a -> m (From k p' a)
298+ where g :: forall a. k a -> From k v a -> m (From k v' a)
489− h k = \case
299+ g k = \case
490 From_Insert v -> From_Insert <$> f k v
300 From_Insert v -> From_Insert <$> f k v
491 From_Delete -> pure From_Delete
301 From_Delete -> pure From_Delete
492− From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
302+ From_Move fromKey -> pure $ From_Move fromKey
493− j :: forall a. k a -> To k p a -> m (To k p' a)
303+
494− j k = \case
495− To_NonMove -> pure To_NonMove
496− To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
497−
498−-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
304+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
499−-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
500−nodeInfoMapFrom
305+nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
501− :: (From k p a -> From k p' a)
502− -> (To k p a -> To k p' a)
503− -> NodeInfo k p a
504− -> NodeInfo k p' a
505−nodeInfoMapFrom f g ni = NodeInfo
506− { _nodeInfo_from = f $ _nodeInfo_from ni
306+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
507− , _nodeInfo_to = g $ _nodeInfo_to ni
307+
508− }
509−
510−-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
308+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
511−-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
512−nodeInfoMapFromM
309+nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
513− :: Applicative f
310+nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
514− => (From k p a -> f (From k p' a))
311+
515− -> (To k p a -> f (To k p' a))
516− -> NodeInfo k p a
517− -> f (NodeInfo k p' a)
518−nodeInfoMapFromM f g ni = NodeInfo
519− <$> f (_nodeInfo_from ni)
520− <*> g (_nodeInfo_to ni)
521−
522−-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithPatchingMove' by weakening the keys
523−-- from @k a@ to @'Some' k@ and applying a given weakening function
312+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
524−-- @PatchTarget1 p a -> v'@ to values.
313+-- values.
525−weakenPatchDMapWithMoveWith
314+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
526− :: forall k p p'
527− . (forall a. PatchTarget1 p a -> PatchTarget p')
528− -> (forall from to. p from to -> p')
529− -> PatchDMapWithMove k p
530− -> PatchMapWithPatchingMove (Some k) p'
531−weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
315+weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
532− PatchMapWithPatchingMove $ weakenDMapWith h m
533− where h :: forall a. NodeInfo k p a -> MapWithPatchingMove.NodeInfo (Some k) p'
316+ where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
534− h ni = MapWithPatchingMove.NodeInfo
317+ g ni = MapWithMove.NodeInfo
535− { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
318+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
536− From_Insert v -> MapWithPatchingMove.From_Insert $ f v
319+ From_Insert v -> MapWithMove.From_Insert $ f v
537− From_Delete -> MapWithPatchingMove.From_Delete
320+ From_Delete -> MapWithMove.From_Delete
538− From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
321+ From_Move k -> MapWithMove.From_Move $ mkSome k
539− , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
322+ , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
540− To_NonMove -> Nothing
541− To_Move (k :=> _) -> Just (mkSome k)
542 }
323 }
543
324
544−-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' k
545−-- 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
546−-- dependency in the typing and all points are already @a@, hence the function
326+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
547−-- to map each value to @v'@ is not higher rank.
548−patchDMapWithMoveToPatchMapWithPatchingMoveWith
549− :: forall k p p' a
550− . (PatchTarget1 p a -> PatchTarget p')
551− -> (p a a -> p')
552− -> PatchDMapWithMove (Const2 k a) p
327+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
553− -> PatchMapWithPatchingMove k p'
328+patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
554−patchDMapWithMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithMove m) =
555− PatchMapWithPatchingMove $ dmapToMapWith h m
556− where h :: NodeInfo (Const2 k a) p a -> MapWithPatchingMove.NodeInfo k p'
329+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
557− h ni = MapWithPatchingMove.NodeInfo
330+ g ni = MapWithMove.NodeInfo
558− { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
331+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
559− From_Insert v -> MapWithPatchingMove.From_Insert $ f v
332+ From_Insert v -> MapWithMove.From_Insert $ f v
560− From_Delete -> MapWithPatchingMove.From_Delete
333+ From_Delete -> MapWithMove.From_Delete
561− From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
334+ From_Move (Const2 k) -> MapWithMove.From_Move k
562− , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
335+ , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
563− To_NonMove -> Nothing
564− To_Move (Const2 k :=> _) -> Just k
565 }
336 }
566
337
567−-- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithMove
568−-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
338+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
569−-- dependently typed one but which always has a constant key type represented by
339+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
570−-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
340+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
571−-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithPatchingMoveWith'
572−const2PatchDMapWithMoveWith
341+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
573− :: forall k v v' a
574− . (v -> v' a)
575− -> PatchMapWithPatchingMove k (Proxy v)
576− -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
577−const2PatchDMapWithMoveWith f (PatchMapWithPatchingMove p) =
578− PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
342+const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
579− where g :: (k, MapWithPatchingMove.NodeInfo k (Proxy v))
580− -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
343+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
581 g (k, ni) = Const2 k :=> NodeInfo
344 g (k, ni) = Const2 k :=> NodeInfo
582− { _nodeInfo_from = case MapWithPatchingMove._nodeInfo_from ni of
345+ { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
583− MapWithPatchingMove.From_Insert v -> From_Insert $ f v
346+ MapWithMove.From_Insert v -> From_Insert $ f v
584− MapWithPatchingMove.From_Delete -> From_Delete
347+ MapWithMove.From_Delete -> From_Delete
585− MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
348+ MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
586− , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
349+ , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
587− Nothing -> To_NonMove
588− Just toKey -> To_Move $ Const2 toKey :=> Proxy3
589 }
350 }
590
351
591-- | Apply the insertions, deletions, and moves to a given 'DMap'.
352-- | Apply the insertions, deletions, and moves to a given 'DMap'.
592−instance ( GCompare k
593− , PatchHet2 p
594− , PatchSource1 p ~ PatchTarget1 p
595− ) => PatchHet (PatchDMapWithMove k p) where
596− type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
597− type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
598−
599−instance ( GCompare k
600− , PatchHet2 p
601− , PatchSource1 p ~ PatchTarget1 p
602− ) => Patch (PatchDMapWithMove k p) where
353+instance GCompare k => Patch (PatchDMapWithMove k v) where
354+ type PatchTarget (PatchDMapWithMove k v) = DMap k v
603− apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
355+ apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
604− -- TODO: return Nothing sometimes --Note: the strict application here is
605− -- critical to ensuring that incremental merges don't hold onto all their
606− -- prerequisite events forever; can we make this more robust?
607− where insertions = DMap.mapMaybeWithKey insertFunc m
356+ where insertions = DMap.mapMaybeWithKey insertFunc p
608− insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
357+ insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
609 insertFunc _ ni = case _nodeInfo_from ni of
358 insertFunc _ ni = case _nodeInfo_from ni of
610 From_Insert v -> Just v
359 From_Insert v -> Just v
611− From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
360+ From_Move k -> DMap.lookup k old
612 From_Delete -> Nothing
361 From_Delete -> Nothing
613− deletions = DMap.mapMaybeWithKey deleteFunc m
362+ deletions = DMap.mapMaybeWithKey deleteFunc p
614− deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
363+ deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
615 deleteFunc _ ni = case _nodeInfo_from ni of
364 deleteFunc _ ni = case _nodeInfo_from ni of
616 From_Delete -> Just $ Constant ()
365 From_Delete -> Just $ Constant ()
617 _ -> Nothing
366 _ -> Nothing
618
367
619−-- | Get the values that will be replaced, deleted, or moved if the given patch
368+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
620−-- is applied to the given 'DMap'.
621−getDeletionsAndMoves
369+getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
622− :: ( GCompare k
623− , PatchSource1 p ~ PatchTarget1 p
624− )
625− => PatchDMapWithMove k p
626− -> DMap k (PatchSource1 p)
627− -> DMap k (Product (PatchTarget1 p) (To k p))
628getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
629 where f _ v ni = Pair v $ _nodeInfo_to ni
371 where f _ v ni = Pair v $ _nodeInfo_to ni
src/Data/Patch/DMapWithMove/By.hsdeleted−89
@@ -1,89 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE Rank2Types #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE StandaloneDeriving #-}
13−{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−{-# LANGUAGE UndecidableSuperClasses #-}
16−
17−module Data.Patch.DMapWithMove.By where
18−
19−import Data.Semigroupoid as Cat
20−
21−import Data.Patch.Class
22−
23−-- | Structure describing a particular change to a key, be it inserting a new
24−-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
25−-- a key (@By_Delete@), or moving a key (@By_Move@).
26−--
27−-- This type isn't used directly as the from field patch, but is instead wrapped
28−-- in an existential. However, it is nice to be able to reason about this in
29−-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
30−data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
31− -- | Insert a new or update an existing key with the given value @PatchTarget1
32− -- p a@
33− By_Insert :: PatchTarget1 p to -> By k p from to
34− -- | Delete the existing key
35− By_Delete :: By k p from to
36− -- | Move the value from the given key @k a@ to this key. The source key
37− -- should also have an entry in the patch giving the current key as
38− -- @_nodeInfo_to@, usually but not necessarily with @By_Delete@.
39− By_Move :: !(k from) -> p from to -> By k p from to
40−
41−deriving instance ( Show (k from), Show (k to)
42− , Show (p from to)
43− , Show (PatchTarget1 p to)
44− ) => Show (By k p from to)
45−deriving instance ( Read (k from), Read (k to)
46− , Read (p from to)
47− , Read (PatchTarget1 p to)
48− ) => Read (By k p from to)
49−deriving instance ( Eq (k from), Eq (k to)
50− , Eq (p from to)
51− , Eq (PatchTarget1 p to)
52− ) => Eq (By k p from to)
53−deriving instance ( Ord (k from), Ord (k to)
54− , Ord (p from to)
55− , Ord (PatchTarget1 p to)
56− ) => Ord (By k p from to)
57−
58−mapByPatch
59− :: PatchTarget1 p0 ~ PatchTarget1 p1
60− => (p0 from to -> p1 from to)
61− -> By k p0 from to
62− -> By k p1 from to
63−mapByPatch f = \case
64− By_Insert v -> By_Insert v
65− By_Delete -> By_Delete
66− By_Move k p -> By_Move k $ f p
67−
68−-- | Compose patches having the same effect as applying the patches in turn:
69−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
70−instance ( PatchSource1 p ~ PatchTarget1 p
71− , Cat.Semigroupoid p
72− , PatchHet2 p
73− ) => Cat.Semigroupoid (By k p) where
74− o p0 p1 = mapByPatch unProjectLocal $
75− oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
76−
77−oLocal
78− :: ( PatchSource1 p ~ PatchTarget1 p
79− , PatchHet2Locally p between after
80− , Cat.Semigroupoid p
81− )
82− => By k p between after
83− -> By k p before between
84− -> By k p before after
85−By_Insert new `oLocal` _ = By_Insert new
86−By_Delete `oLocal` _ = By_Delete
87−By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2Locally x y
88−By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
89−By_Move _ _ `oLocal` By_Delete = By_Delete
src/Data/Patch/IntMap.hs+1−3
@@ -38,10 +38,8 @@ deriving instance Semigroup (PatchIntMap v)
38makeWrapped ''PatchIntMap
38makeWrapped ''PatchIntMap
39
39
40-- | Apply the insertions or deletions to a given 'IntMap'.
40-- | Apply the insertions or deletions to a given 'IntMap'.
41−instance PatchHet (PatchIntMap a) where
42− type PatchSource (PatchIntMap a) = IntMap a
43− type PatchTarget (PatchIntMap a) = IntMap a
44instance Patch (PatchIntMap a) where
41instance Patch (PatchIntMap a) where
42+ type PatchTarget (PatchIntMap a) = IntMap a
45 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
43 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
46 let removes = IntMap.filter isNothing p
44 let removes = IntMap.filter isNothing p
47 adds = IntMap.mapMaybe id p
45 adds = IntMap.mapMaybe id p
src/Data/Patch/Map.hs+1−3
@@ -45,10 +45,8 @@ instance Ord k => Semigroup (PatchMap k v) where
45 stimes = stimesIdempotentMonoid
45 stimes = stimesIdempotentMonoid
46
46
47-- | Apply the insertions or deletions to a given 'Map'.
47-- | Apply the insertions or deletions to a given 'Map'.
48−instance Ord k => PatchHet (PatchMap k v) where
49− type PatchSource (PatchMap k v) = Map k v
50− type PatchTarget (PatchMap k v) = Map k v
51instance Ord k => Patch (PatchMap k v) where
48instance Ord k => Patch (PatchMap k v) where
49+ type PatchTarget (PatchMap k v) = Map k v
52 {-# INLINABLE apply #-}
50 {-# INLINABLE apply #-}
53 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
51 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
54 where insertions = Map.mapMaybeWithKey (const id) p
52 where insertions = Map.mapMaybeWithKey (const id) p
src/Data/Patch/MapWithMove.hs+8−11
@@ -137,7 +137,7 @@ instance TraversableWithIndex k (PatchMapWithMove k) where
137
137
138-- | Create a 'PatchMapWithMove', validating it
138-- | Create a 'PatchMapWithMove', validating it
139patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
139patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
140−patchMapWithMove = fmap coerce . PM.patchMapWithPatchingMove . coerce
140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
141
141
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
@@ -175,14 +175,11 @@ deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
175--
175--
176-- __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.
177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178−unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
179
179
180-- | Apply the insertions, deletions, and moves to a given 'Map'
180-- | Apply the insertions, deletions, and moves to a given 'Map'
181−instance Ord k => PatchHet (PatchMapWithMove k v) where
182− type PatchSource (PatchMapWithMove k v) = Map k v
183− type PatchTarget (PatchMapWithMove k v) = Map k v
184−
185instance Ord k => Patch (PatchMapWithMove k v) where
181instance Ord k => Patch (PatchMapWithMove k v) where
182+ type PatchTarget (PatchMapWithMove k v) = Map k v
186 apply (PatchMapWithMove' p) = apply p
183 apply (PatchMapWithMove' p) = apply p
187
184
188-- | 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'.
@@ -202,7 +199,7 @@ patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
202-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
203-- 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
204-- values sorted with the given ordering function.
201-- values sorted with the given ordering function.
205−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
206patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
207 where newList = Map.toList newByIndexUnsorted
204 where newList = Map.toList newByIndexUnsorted
208 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
@@ -258,13 +255,13 @@ bitraverseNodeInfo
258 => (k0 -> f k1)
255 => (k0 -> f k1)
259 -> (v0 -> f v1)
256 -> (v0 -> f v1)
260 -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
257 -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
261−bitraverseNodeInfo fk fv = fmap coerce
258+bitraverseNodeInfo fk fv = fmap NodeInfo'
262 . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
259 . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
263 . coerce
260 . coerce
264
261
265-- | Change the 'From' value of a 'NodeInfo'
262-- | Change the 'From' value of a 'NodeInfo'
266nodeInfoMapFrom :: (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
267−nodeInfoMapFrom f = coerce . PM.nodeInfoMapFrom (unFrom' . f . From') . coerce
264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
268
265
269-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
270-- 'Applicative', 'Monad', etc.) action to get the new value
267-- 'Applicative', 'Monad', etc.) action to get the new value
@@ -272,7 +269,7 @@ nodeInfoMapMFrom
272 :: Functor f
269 :: Functor f
273 => (From k v -> f (From k v))
270 => (From k v -> f (From k v))
274 -> NodeInfo k v -> f (NodeInfo k v)
271 -> NodeInfo k v -> f (NodeInfo k v)
275−nodeInfoMapMFrom f = fmap coerce
272+nodeInfoMapMFrom f = fmap NodeInfo'
276 . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
273 . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
277 . coerce
274 . coerce
278
275
@@ -306,7 +303,7 @@ bitraverseFrom
306 => (k0 -> f k1)
303 => (k0 -> f k1)
307 -> (v0 -> f v1)
304 -> (v0 -> f v1)
308 -> From k0 v0 -> f (From k1 v1)
305 -> From k0 v0 -> f (From k1 v1)
309−bitraverseFrom fk fv = fmap coerce
306+bitraverseFrom fk fv = fmap From'
310 . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
307 . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
311 . coerce
308 . coerce
312
309
src/Data/Patch/MapWithPatchingMove.hs+36−38
@@ -48,10 +48,10 @@ module Data.Patch.MapWithPatchingMove
48
48
49import Data.Patch.Class
49import Data.Patch.Class
50
50
51−import Control.Arrow
51+import Control.Lens hiding (from, to)
52import Control.Lens.TH (makeWrapped)
52import Control.Lens.TH (makeWrapped)
53−import Control.Monad.Trans.State
53+import Data.Align (align)
54−import Data.Foldable
54+import Data.Foldable (toList)
55import Data.Function
55import Data.Function
56import Data.List
56import Data.List
57import Data.Map (Map)
57import Data.Map (Map)
@@ -61,9 +61,9 @@ import Data.Maybe
61import Data.Semigroup (Semigroup (..))
61import Data.Semigroup (Semigroup (..))
62#endif
62#endif
63import Data.Monoid.DecidablyEmpty
63import Data.Monoid.DecidablyEmpty
64+import Data.Set (Set)
64import qualified Data.Set as Set
65import qualified Data.Set as Set
65import Data.These (These (..))
66import Data.These (These (..))
66−import Data.Tuple
67
67
68-- | 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@
69-- 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@,
@@ -170,11 +170,8 @@ unsafePatchMapWithPatchingMove
170unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
170unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
171
171
172-- | Apply the insertions, deletions, and moves to a given 'Map'
172-- | Apply the insertions, deletions, and moves to a given 'Map'
173−instance (Ord k, Patch p) => PatchHet (PatchMapWithPatchingMove k p) where
174− type PatchSource (PatchMapWithPatchingMove k p) = Map k (PatchSource p)
175− type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
176−
177instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
173instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
174+ type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
178 -- TODO: return Nothing sometimes
175 -- TODO: return Nothing sometimes
179 -- Note: the strict application here is critical to ensuring that incremental
176 -- Note: the strict application here is critical to ensuring that incremental
180 -- merges don't hold onto all their prerequisite events forever; can we make
177 -- merges don't hold onto all their prerequisite events forever; can we make
@@ -232,39 +229,40 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
232
229
233-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
234-- will produce the second 'Map'.
231-- will produce the second 'Map'.
232+-- Note: this will never produce a patch on a value.
235patchThatChangesMap
233patchThatChangesMap
234+ :: forall k p
236− :: (Ord k, Ord (PatchTarget p), Monoid p)
235+ . (Ord k, Ord (PatchTarget p), Monoid p)
237 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
238patchThatChangesMap oldByIndex newByIndex = patch
237patchThatChangesMap oldByIndex newByIndex = patch
239− 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)
240− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
239+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
241− let f k v = do
240+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
242− remainingValues <- get
241+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
243− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
242+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
244− 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))
245− else Map.insert v remainingKeys remainingValues
244+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
246− case Map.lookup v remainingValues of
245+ -- Generate patch info for a single value
247− 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
248− 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
249− 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
250− then do
249+ patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
251− 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
252− 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
253− 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
254− (fromK, remainingKeys) <- return $
253+ These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
255− fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
254+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
256− Set.minView fromKs -- There's an existing value, but it's not here; move it here
255+ patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
257− putRemainingKeys remainingKeys
256+ patchSingleValueThese v = \case
258− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
257+ This oldKeys -> patchSingleValue v oldKeys mempty
259− Map.traverseWithKey f newByIndex
258+ That newKeys -> patchSingleValue v mempty newKeys
260− unusedOldKeys = fold unusedValuesByValue
259+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
261− pointlessMove k = \case
260+ -- Generate froms and tos for all values, then merge them together
262− From_Move k' _ | k == k' -> True
261+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
263− _ -> False
262+ patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
264− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
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.
265− then Just undefined
264+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
266− else Nothing
265+ These from to -> NodeInfo from to
267− 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
268
266
269--
267--
270-- NodeInfo
268-- NodeInfo
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/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