on 6ef716a 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 --enable-tests all
45+ run: cabal test all
46 - name: Build Docs
46 - name: Build Docs
47 run: cabal haddock
47 run: cabal haddock
.travis.ymlnew file+171
@@ -0,0 +1,171 @@
1+# This Travis job script has been generated by a script via
2+#
3+# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4+#
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.3.20190814
8+#
9+language: c
10+dist: xenial
11+sudo: required
12+git:
13+ # whether to recursively clone submodules
14+ submodules: false
15+cache:
16+ directories:
17+ - $HOME/.cabal/packages
18+ - $HOME/.cabal/store
19+before_cache:
20+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
21+ # remove files that are regenerated by 'cabal update'
22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
23+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
26+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
27+ - rm -rfv $CABALHOME/packages/head.hackage
28+matrix:
29+ include:
30+ - compiler: ghcjs-8.4
31+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}
32+ - compiler: ghc-8.8.1
33+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34+ - compiler: ghc-8.6.5
35+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}
36+ - compiler: ghc-8.4.4
37+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}
38+ - compiler: ghc-8.2.2
39+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}
40+ - compiler: ghc-8.0.2
41+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
42+before_install:
43+ - |
44+ if [ "$TRAVIS_OS_NAME" = "linux" ]; then
45+ sudo add-apt-repository -y ppa:hvr/ghcjs;
46+ curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -
47+ sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main'
48+ sudo apt-get update;
49+ sudo apt-get install $CC cabal-install-3.0 nodejs;
50+ fi
51+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
52+ - WITHCOMPILER="-w $HC"
53+ - |
54+ if echo $CC | grep -q ghcjs; then
55+ GHCJS=true
56+ HC=${HC}js
57+ WITHCOMPILER="--ghcjs ${WITHCOMPILER}js"
58+ else
59+ GHCJS=false;
60+ fi
61+ - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi
62+ - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
63+ - HCPKG="$HC-pkg"
64+ - unset CC
65+ - CABAL=/opt/ghc/bin/cabal
66+ - CABALHOME=$HOME/.cabal
67+ - export PATH="$CABALHOME/bin:$PATH"
68+ - TOP=$(pwd)
69+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
70+ - echo $HCNUMVER
71+ - CABAL="$CABAL -vnormal+nowrap+markoutput"
72+ - set -o pipefail
73+ - |
74+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
75+ echo 'BEGIN { state = "output"; }' >> .colorful.awk
76+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
77+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
78+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
79+ echo ' if (state == "cabal") {' >> .colorful.awk
80+ echo ' print blue($0)' >> .colorful.awk
81+ echo ' } else {' >> .colorful.awk
82+ echo ' print $0' >> .colorful.awk
83+ echo ' }' >> .colorful.awk
84+ echo '}' >> .colorful.awk
85+ - cat .colorful.awk
86+ - |
87+ color_cabal_output () {
88+ awk -f $TOP/.colorful.awk
89+ }
90+ - echo text | color_cabal_output
91+install:
92+ - ${CABAL} --version
93+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
94+ - node --version
95+ - echo $GHCJS
96+ - TEST=--enable-tests
97+ - BENCH=--enable-benchmarks
98+ - BENCH=--disable-benchmarks
99+ - HEADHACKAGE=false
100+ - rm -f $CABALHOME/config
101+ - |
102+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
103+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config
104+ echo "write-ghc-environment-files: always" >> $CABALHOME/config
105+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
106+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
107+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config
108+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
109+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
110+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
111+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
112+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
113+ echo "install-dirs user" >> $CABALHOME/config
114+ echo " prefix: $CABALHOME" >> $CABALHOME/config
115+ echo "repository hackage.haskell.org" >> $CABALHOME/config
116+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
117+ - cat $CABALHOME/config
118+ - rm -fv cabal.project cabal.project.local cabal.project.freeze
119+ - travis_retry ${CABAL} v2-update -v
120+ - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi
121+ # Generate cabal.project
122+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
123+ - touch cabal.project
124+ - |
125+ echo "packages: ." >> cabal.project
126+ - |
127+ - cat cabal.project || true
128+ - cat cabal.project.local || true
129+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
130+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
131+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
132+ - rm cabal.project.freeze
133+script:
134+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
135+ # Packaging...
136+ - ${CABAL} v2-sdist all | color_cabal_output
137+ # Unpacking...
138+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
139+ - cd ${DISTDIR} || false
140+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
141+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
142+ - PKGDIR_patch="$(find . -maxdepth 1 -type d -regex '.*/patch-[0-9.]*')"
143+ # Generate cabal.project
144+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
145+ - touch cabal.project
146+ - |
147+ echo "packages: ${PKGDIR_patch}" >> cabal.project
148+ - |
149+ - cat cabal.project || true
150+ - cat cabal.project.local || true
151+ # Building...
152+ # this builds all libraries and executables (without tests/benchmarks)
153+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
154+ # Building with tests and benchmarks...
155+ # build & run tests, build benchmarks
156+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
157+ # Testing...
158+ - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
159+ # cabal check...
160+ - (cd ${PKGDIR_patch} && ${CABAL} -vnormal check)
161+ # haddock...
162+ - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
163+ # Constraint sets
164+ - rm -rf cabal.project.local
165+ # Constraint set old-these
166+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi
167+ # Constraint set old-witherable
168+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output
169+
170+# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
171+# EOF
ChangeLog.md+10−14
@@ -2,13 +2,9 @@
2
2
3## Unreleased
3## Unreleased
4
4
5−* New dep of `data-orphans` for old GHC to get instances honestly instead of
5+* `PatchMapWithMove` supports moves with a patch.
6− via `monoidal-containers`.
7
6
8−## 0.0.5.0 - 2021-12-17
7+* `PatchDMapWithMove` supports moves with a patch.
9−
10−* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
11− from `Data.Patch` for compatability.
12
8
13* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
9* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
14 Care is taken to make this not a breaking change.
10 Care is taken to make this not a breaking change.
@@ -16,25 +12,25 @@
16 There are complete constructor and field patterns too, and everything is
12 There are complete constructor and field patterns too, and everything is
17 exported under the newtype as real constructors and fields would be.
13 exported under the newtype as real constructors and fields would be.
18
14
19−## 0.0.4.0 - 2021-04-20
15+## 0.0.4.0
20
16
21* Enable PolyKinds
17* Enable PolyKinds
22
18
23−## 0.0.3.2 - 2020-11-06
19+## 0.0.3.2
24
20
25* Update version bounds
21* Update version bounds
26
22
27−## 0.0.3.1 - 2020-02-05
23+## 0.0.3.1
28
24
29* Replace `fromJust` with something easier to debug.
25* Replace `fromJust` with something easier to debug.
30
26
31−## 0.0.3.0 - 2020-02-05
27+## 0.0.3.0
32
28
33* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
29* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
34
30
35* Create `DecidablyEmpty` subclass of `Monoid`.
31* Create `DecidablyEmpty` subclass of `Monoid`.
36
32
37−## 0.0.2.0 - 2020-01-17
33+## 0.0.2.0
38
34
39* Consistently provide:
35* Consistently provide:
40
36
@@ -46,16 +42,16 @@
46
42
47 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
43 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
48
44
49−## 0.0.1.0 - 2020-01-09
45+## 0.0.1.0
50
46
51* Support older GHCs with `split-these` flag.
47* Support older GHCs with `split-these` flag.
52
48
53* Additional instances for the `Group` class for basic types.
49* Additional instances for the `Group` class for basic types.
54
50
55−## 0.0.0.1 - 2020-01-08
51+## 0.0.0.1
56
52
57* Remove unneeded dependencies
53* Remove unneeded dependencies
58
54
59−## 0.0.0.0 - 2020-01-08
55+## 0.0.0.0
60
56
61* Extract patching functionality from Reflex.
57* Extract patching functionality from Reflex.
cabal.haskell-cinew file+14
@@ -0,0 +1,14 @@
1+distribution: xenial
2+benchmarks: False
3+unconstrained: False
4+installed: -all
5+
6+-- https://github.com/haskell/cabal/issues/6106
7+install-dependencies: False
8+
9+constraint-set old-these
10+ ghc: <8.8
11+ constraints: these <1
12+
13+constraint-set old-witherable
14+ constraints: witherable <0.3.2
patch.cabal+6−20
@@ -1,5 +1,5 @@
1Name: patch
1Name: patch
2−Version: 0.0.5.0
2+Version: 0.0.4.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,47 +41,33 @@ library
41 , lens >= 4.7 && < 5
41 , lens >= 4.7 && < 5
42 , semigroupoids >= 4.0 && < 6
42 , semigroupoids >= 4.0 && < 6
43 , transformers >= 0.5.6.0 && < 0.6
43 , transformers >= 0.5.6.0 && < 0.6
44− , witherable >= 0.3 && < 0.5
44+ , witherable >= 0.3 && < 0.4
45
45
46− if impl(ghc < 8.6) -- really, if base < 8.12
46+ exposed-modules: Control.Category.DecidablyEmpty
47− build-depends: base-orphans >= 0.8 && < 0.9
48−
49− exposed-modules: Data.Functor.Misc
47+ , Data.Functor.Misc
50 , Data.Monoid.DecidablyEmpty
48 , Data.Monoid.DecidablyEmpty
51 , Data.Patch
49 , Data.Patch
52 , Data.Patch.Class
50 , Data.Patch.Class
53 , Data.Patch.DMap
51 , Data.Patch.DMap
54 , Data.Patch.DMapWithMove
52 , Data.Patch.DMapWithMove
53+ , Data.Patch.DMapWithMove.By
55 , Data.Patch.IntMap
54 , Data.Patch.IntMap
56 , Data.Patch.Map
55 , Data.Patch.Map
57 , Data.Patch.MapWithMove
56 , Data.Patch.MapWithMove
58 , Data.Patch.MapWithPatchingMove
57 , Data.Patch.MapWithPatchingMove
59− , Data.Semigroup.Additive
60
58
61 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
59 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
62 default-extensions: PolyKinds
60 default-extensions: PolyKinds
63
61
64 if flag(split-these)
62 if flag(split-these)
65 build-depends: these >= 1 && <1.2
63 build-depends: these >= 1 && <1.2
64+ , these-lens >= 1 && <1.1
66 , semialign >=1 && <1.2
65 , semialign >=1 && <1.2
67 , monoidal-containers >= 0.6 && < 0.7
66 , monoidal-containers >= 0.6 && < 0.7
68 else
67 else
69 build-depends: these >= 0.4 && <0.9
68 build-depends: these >= 0.4 && <0.9
70 , monoidal-containers == 0.4.0.0
69 , monoidal-containers == 0.4.0.0
71
70
72−test-suite tests
73− default-language: Haskell2010
74− type: exitcode-stdio-1.0
75− main-is: tests.hs
76− hs-source-dirs: test
77− build-depends: base
78− , patch
79− , containers
80− , hedgehog
81− , HUnit
82− if impl(ghcjs)
83− buildable: False
84−
85test-suite hlint
71test-suite hlint
86 default-language: Haskell2010
72 default-language: Haskell2010
87 type: exitcode-stdio-1.0
73 type: exitcode-stdio-1.0
src/Control/Category/DecidablyEmpty.hsnew file+9
@@ -0,0 +1,9 @@
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+28−5
@@ -1,6 +1,6 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
@@ -16,6 +16,8 @@
16module Data.Functor.Misc
16module Data.Functor.Misc
17 ( -- * Const2
17 ( -- * Const2
18 Const2 (..)
18 Const2 (..)
19+ , Proxy3 (..)
20+ , First2 (..)
19 , unConst2
21 , unConst2
20 , dmapToMap
22 , dmapToMap
21 , dmapToIntMap
23 , dmapToIntMap
@@ -36,6 +38,7 @@ module Data.Functor.Misc
36 , ComposeMaybe (..)
38 , ComposeMaybe (..)
37 ) where
39 ) where
38
40
41+import qualified Control.Category as Cat
39import Control.Applicative ((<$>))
42import Control.Applicative ((<$>))
40import Data.Dependent.Map (DMap)
43import Data.Dependent.Map (DMap)
41import qualified Data.Dependent.Map as DMap
44import qualified Data.Dependent.Map as DMap
@@ -47,6 +50,7 @@ import Data.IntMap (IntMap)
47import qualified Data.IntMap as IntMap
50import qualified Data.IntMap as IntMap
48import Data.Map (Map)
51import Data.Map (Map)
49import qualified Data.Map as Map
52import qualified Data.Map as Map
53+import qualified Data.Semigroupoid as Cat
50import Data.Some (Some, mkSome)
54import Data.Some (Some, mkSome)
51import Data.These
55import Data.These
52import Data.Type.Equality ((:~:)(Refl))
56import Data.Type.Equality ((:~:)(Refl))
@@ -62,15 +66,15 @@ data Const2 :: * -> x -> x -> * where
62 Const2 :: k -> Const2 k v v
66 Const2 :: k -> Const2 k v v
63 deriving (Typeable)
67 deriving (Typeable)
64
68
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+
74instance Show k => GShow (Const2 k v) where
78instance Show k => GShow (Const2 k v) where
75 gshowsPrec n x@(Const2 _) = showsPrec n x
79 gshowsPrec n x@(Const2 _) = showsPrec n x
76
80
@@ -86,6 +90,25 @@ instance Ord k => GCompare (Const2 k v) where
86 EQ -> GEQ
90 EQ -> GEQ
87 GT -> GGT
91 GT -> GGT
88
92
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+
89-- | Convert a 'DMap' to a regular 'Map'
112-- | Convert a 'DMap' to a regular 'Map'
90dmapToMap :: DMap (Const2 k v) Identity -> Map k v
113dmapToMap :: DMap (Const2 k v) Identity -> Map k v
91dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
114dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
src/Data/Patch.hs+22−9
@@ -23,12 +23,11 @@ import Data.Semigroup (Semigroup (..))
23#endif
23#endif
24import GHC.Generics
24import GHC.Generics
25
25
26−import Data.Semigroup.Additive as X
27import Data.Patch.Class as X
26import Data.Patch.Class as X
28import Data.Patch.DMap as X hiding (getDeletions)
27import Data.Patch.DMap as X hiding (getDeletions)
29import Data.Patch.DMapWithMove as X
28import Data.Patch.DMapWithMove as X
30 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
29 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
31− , patchDMapWithMoveToPatchMapWithMoveWith
30+ , patchDMapWithMoveToPatchMapWithPatchingMoveWith
32 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
31 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
33 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
32 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
34 )
33 )
@@ -46,25 +45,34 @@ class (Semigroup q, Monoid q) => Group q where
46 (~~) :: q -> q -> q
45 (~~) :: q -> q -> q
47 r ~~ s = r <> negateG s
46 r ~~ s = r <> negateG s
48
47
48+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
49+class Semigroup q => Additive q where
50+
49-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
51-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
50newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
52newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
51
53
52−instance Additive p => Patch (AdditivePatch p) where
54+instance Additive p => PatchHet (AdditivePatch p) where
55+ type PatchSource (AdditivePatch p) = p
53 type PatchTarget (AdditivePatch p) = p
56 type PatchTarget (AdditivePatch p) = p
57+instance Additive p => Patch (AdditivePatch p) where
54 apply (AdditivePatch p) q = Just $ p <> q
58 apply (AdditivePatch p) q = Just $ p <> q
55
59
56instance (Ord k, Group q) => Group (MonoidalMap k q) where
60instance (Ord k, Group q) => Group (MonoidalMap k q) where
57 negateG = fmap negateG
61 negateG = fmap negateG
58
62
63+instance (Ord k, Additive q) => Additive (MonoidalMap k q)
64+
59-- | Trivial group.
65-- | Trivial group.
60instance Group () where
66instance Group () where
61− negateG _ = ()
67+ negateG ~() = ()
62− _ ~~ _ = ()
68+ ~() ~~ ~() = ()
69+instance Additive ()
63
70
64-- | Product group. A Pair of groups gives rise to a group
71-- | Product group. A Pair of groups gives rise to a group
65instance (Group a, Group b) => Group (a, b) where
72instance (Group a, Group b) => Group (a, b) where
66 negateG (a, b) = (negateG a, negateG b)
73 negateG (a, b) = (negateG a, negateG b)
67 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
74 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
75+instance (Additive a, Additive b) => Additive (a, b)
68
76
69-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
77-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
70-- Base does not define Monoid (Compose f g a) so this is the best we can
78-- Base does not define Monoid (Compose f g a) so this is the best we can
@@ -72,24 +80,29 @@ instance (Group a, Group b) => Group (a, b) where
72instance Group (f (g a)) => Group ((f :.: g) a) where
80instance Group (f (g a)) => Group ((f :.: g) a) where
73 negateG (Comp1 xs) = Comp1 (negateG xs)
81 negateG (Comp1 xs) = Comp1 (negateG xs)
74 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
82 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
83+instance Additive (f (g a)) => Additive ((f :.: g) a)
75
84
76-- | Product of groups, Functor style.
85-- | Product of groups, Functor style.
77instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
86instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
78 negateG (a :*: b) = negateG a :*: negateG b
87 negateG (a :*: b) = negateG a :*: negateG b
79 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
88 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
89+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
80
90
81-- | Trivial group, Functor style
91-- | Trivial group, Functor style
82instance Group (Proxy x) where
92instance Group (Proxy x) where
83− negateG _ = Proxy
93+ negateG ~Proxy = Proxy
84− _ ~~ _ = Proxy
94+ ~Proxy ~~ ~Proxy = Proxy
95+instance Additive (Proxy x)
85
96
86-- | Const lifts groups into a functor.
97-- | Const lifts groups into a functor.
87deriving instance Group a => Group (Const a x)
98deriving instance Group a => Group (Const a x)
88−
99+instance Additive a => Additive (Const a x)
89−-- | Identity lifts groups pointwise (at only one point)
100+-- | Ideitnty lifts groups pointwise (at only one point)
90deriving instance Group a => Group (Identity a)
101deriving instance Group a => Group (Identity a)
102+instance Additive a => Additive (Identity a)
91
103
92-- | Functions lift groups pointwise.
104-- | Functions lift groups pointwise.
93instance Group b => Group (a -> b) where
105instance Group b => Group (a -> b) where
94 negateG f = negateG . f
106 negateG f = negateG . f
95 (~~) = liftA2 (~~)
107 (~~) = liftA2 (~~)
108+instance Additive b => Additive (a -> b)
src/Data/Patch/Class.hs+131−5
@@ -1,23 +1,58 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
4-- | The interface for types which represent changes made to other types
11-- | The interface for types which represent changes made to other types
5module Data.Patch.Class where
12module Data.Patch.Class where
6
13
14+import qualified Data.Semigroupoid as Cat
7import Data.Functor.Identity
15import Data.Functor.Identity
16+import Data.Functor.Misc
8import Data.Kind (Type)
17import Data.Kind (Type)
9import Data.Maybe
18import Data.Maybe
10#if !MIN_VERSION_base(4,11,0)
19#if !MIN_VERSION_base(4,11,0)
11import Data.Semigroup (Semigroup(..))
20import Data.Semigroup (Semigroup(..))
12#endif
21#endif
13import Data.Proxy
22import 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'
14
48
15-- | A 'Patch' type represents a kind of change made to a datastructure.
49-- | A 'Patch' type represents a kind of change made to a datastructure.
16--
50--
17-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
51-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
18-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
52-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
53+class ( PatchHet p
54+ , PatchSource p ~ PatchTarget p
19−class Patch p where
55+ ) => Patch p where
20− type PatchTarget p :: Type
21 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
56 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
22 -- 'Nothing'.
57 -- 'Nothing'.
23 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
58 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -27,19 +62,110 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
27applyAlways p t = fromMaybe t $ apply p t
62applyAlways p t = fromMaybe t $ apply p t
28
63
29-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
64-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
30−instance Patch (Identity a) where
65+instance PatchHet (Identity a) where
66+ type PatchSource (Identity a) = a
31 type PatchTarget (Identity a) = a
67 type PatchTarget (Identity a) = a
68+instance Patch (Identity a) where
32 apply (Identity a) _ = Just a
69 apply (Identity a) _ = Just a
33
70
34-- | 'Proxy' can be used as a 'Patch' that does nothing.
71-- | 'Proxy' can be used as a 'Patch' that does nothing.
35−instance forall (a :: Type). Patch (Proxy a) where
72+instance forall (a :: Type). PatchHet (Proxy a) where
73+ type PatchSource (Proxy a) = a
36 type PatchTarget (Proxy a) = a
74 type PatchTarget (Proxy a) = a
75+instance forall (a :: Type). Patch (Proxy a) where
37 apply ~Proxy _ = Nothing
76 apply ~Proxy _ = Nothing
38
77
39-- | Like '(.)', but composes functions that return patches rather than
78-- | Like '(.)', but composes functions that return patches rather than
40-- functions that return new values. The Semigroup instance for patches must
79-- functions that return new values. The Semigroup instance for patches must
41-- apply patches right-to-left, like '(.)'.
80-- apply patches right-to-left, like '(.)'.
42−composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
81+composePatchFunctions
82+ :: (Patch p, Semigroup p)
83+ => (PatchTarget p -> p)
84+ -> (PatchTarget p -> p)
85+ -> PatchTarget p -> p
43composePatchFunctions g f a =
86composePatchFunctions g f a =
44 let fp = f a
87 let fp = f a
45 in g (applyAlways fp a) <> fp
88 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+3−1
@@ -42,8 +42,10 @@ 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 => Patch (PatchDMap k v) where
45+instance GCompare k => PatchHet (PatchDMap k v) where
46+ type PatchSource (PatchDMap k v) = DMap k v
46 type PatchTarget (PatchDMap k v) = DMap k v
47 type PatchTarget (PatchDMap k v) = DMap k v
48+instance GCompare k => Patch (PatchDMap k v) where
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?
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?
48 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
50 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
49 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
51 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
src/Data/Patch/DMapWithMove.hs+419−161
@@ -1,108 +1,234 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE Rank2Types #-}
11{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
11{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableSuperClasses #-}
13
17
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
18-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
15-- move values between keys.
19-- move values between keys.
16module Data.Patch.DMapWithMove where
20module Data.Patch.DMapWithMove where
17
21
18−import Data.Patch.Class
22+import qualified Control.Category as Cat
19−import Data.Patch.MapWithMove (PatchMapWithMove (..))
23+--import qualified Control.Category.DecidablyEmpty as Cat
20−import qualified Data.Patch.MapWithMove as MapWithMove
21
24
22−import Data.Constraint.Extras
25+import Data.Constraint.Extras (Has')
23import Data.Dependent.Map (DMap)
26import Data.Dependent.Map (DMap)
24import Data.Dependent.Sum (DSum (..))
27import Data.Dependent.Sum (DSum (..))
25import qualified Data.Dependent.Map as DMap
28import qualified Data.Dependent.Map as DMap
26−import Data.Functor.Constant
29+import Data.Functor.Constant (Constant (..))
27import Data.Functor.Misc
30import Data.Functor.Misc
31+ ( Const2 (..), Proxy3 (..)
32+ , weakenDMapWith
33+ , dmapToMapWith
34+ )
28−import Data.Functor.Product
35+import Data.Functor.Product (Product (..))
29import Data.GADT.Compare (GEq (..), GCompare (..))
36import Data.GADT.Compare (GEq (..), GCompare (..))
30−import Data.GADT.Show (GShow, gshow)
37+import Data.GADT.Show (GRead, GShow, gshow)
31import qualified Data.Map as Map
38import qualified Data.Map as Map
32import Data.Maybe
39import Data.Maybe
33import Data.Monoid.DecidablyEmpty
40import Data.Monoid.DecidablyEmpty
41+import Data.Semigroupoid as Cat
34#if !MIN_VERSION_base(4,11,0)
42#if !MIN_VERSION_base(4,11,0)
35−import Data.Semigroup (Semigroup (..))
43+import Data.Semigroup (Semigroup (..), (<>))
36#endif
44#endif
37import Data.Some (Some, mkSome)
45import Data.Some (Some, mkSome)
38−import Data.These
46+import Data.Proxy (Proxy (..))
47+import Data.These (These (..))
39
48
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'
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
58+-- which describes how it will be changed by the patch and connects move sources
41−-- destinations.
59+-- and destinations.
42--
60--
43-- Invariants:
61-- Invariants:
44--
62--
45−-- * A key should not move to itself.
63+-- * A key should not move to itself.
64+--
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)@)
65+-- * A move should always be represented with both the destination key (as a
66+-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
67+-- destination)@)
47newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
68newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
48
69
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+
49-- It won't let me derive for some reason
87-- 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
50−instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
92+ ) => DecidablyEmpty (PatchDMapWithMove k v) where
51 isEmpty (PatchDMapWithMove m) = DMap.null m
93 isEmpty (PatchDMapWithMove m) = DMap.null m
52
94
95+-- | Structure which represents what changes apply to a particular key.
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
96+-- @_nodeInfo_from@ specifies what happens to this key, and in particular 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.
97+-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
98+-- key the current key is moving to if involved in a move.
55−data NodeInfo k v a = NodeInfo
99+data NodeInfo k p a = NodeInfo
56− { _nodeInfo_from :: !(From k v a)
100+ { _nodeInfo_from :: !(From k p a)
57− -- ^Change applying to the current key, be it an insert, move, or delete.
101+ -- ^ Change applying to the current key, be it an insert, move, or delete.
58− , _nodeInfo_to :: !(To k a)
102+ , _nodeInfo_to :: !(To k p a)
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'.
103+ -- ^ Where this key is moving to, if involved in a move. Should only be
104+ -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
60 }
105 }
106+
61− deriving (Show)
107+--deriving instance ( Show (k a)
62−
108+-- , Show (p a a)
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+
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
124+-- | Structure describing a particular change to a key, be it inserting a new
125+-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
64−-- key (@From_Delete@), or moving a key (@From_Move@).
126+-- a 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.
65−data From (k :: a -> *) (v :: a -> *) :: a -> * where
131+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
66− -- |Insert a new or update an existing key with the given value @v a@
132+ -- | Insert a new or update an existing key with the given value @PatchTarget1
133+ -- p a@
67− From_Insert :: v a -> From k v a
134+ From_Insert :: PatchTarget1 p to -> From k p to
68− -- |Delete the existing key
135+ -- | Delete the existing key
69− From_Delete :: From k v a
136+ From_Delete :: From k p to
137+ -- | Move the value from the given key @k a@ to this key. The source key
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@,
138+ -- should also have an entry in the patch giving the current key as
71− -- usually but not necessarily with @From_Delete@.
139+ -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
72− From_Move :: !(k a) -> From k v a
140+ From_Move :: !(DSum k (Flip p to)) -> From k p to
73− deriving (Show, Read, Eq, Ord)
141+
74−
142+deriving instance ( Show (k a), GShow k
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
143+ , Has' Show k (Flip p a)
76−-- operation.
144+ , Show (PatchTarget1 p a)
77−type To = ComposeMaybe
145+ ) => Show (From k p a)
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)
78
194
79-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
195-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
80−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
196+validPatchDMapWithMove
197+ :: forall k v
198+ . (GCompare k, GShow k)
199+ => DMap k (NodeInfo k v)
200+ -> Bool
81validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
201validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
82
202
83-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
203-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
84−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
204+validationErrorsForPatchDMapWithMove
205+ :: forall k v
206+ . (GCompare k, GShow k)
207+ => DMap k (NodeInfo k v)
208+ -> [String]
85validationErrorsForPatchDMapWithMove m =
209validationErrorsForPatchDMapWithMove m =
86 noSelfMoves <> movesBalanced
210 noSelfMoves <> movesBalanced
87 where
211 where
88 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
212 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
213+ selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
89− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
214+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
215+ selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
90− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
216+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
91 selfMove _ = Nothing
217 selfMove _ = Nothing
92 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
218 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
93− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
219+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
94 case DMap.lookup src m of
220 case DMap.lookup src m of
95 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
221 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
96− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
222+ Just (NodeInfo _ (To_Move (dst' :=> _))) ->
97 if isNothing (dst' `geq` dst)
223 if isNothing (dst' `geq` dst)
98 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
224 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
99 else Nothing
225 else Nothing
100 _ ->
226 _ ->
101 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
227 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
102− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
228+ unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
103 case DMap.lookup dst m of
229 case DMap.lookup dst m of
104 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
230 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
105− Just (NodeInfo (From_Move src') _) ->
231+ Just (NodeInfo (From_Move (src' :=> _)) _) ->
106 if isNothing (src' `geq` src)
232 if isNothing (src' `geq` src)
107 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
233 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
108 else Nothing
234 else Nothing
@@ -111,35 +237,49 @@ validationErrorsForPatchDMapWithMove m =
111 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
237 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
112 unbalancedMove _ = Nothing
238 unbalancedMove _ = Nothing
113
239
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−
118-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
240-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
119data Pair1 f g a = Pair1 (f a) (g a)
241data Pair1 f g a = Pair1 (f a) (g a)
120
242
121-- |Helper data structure used for composing patches using the monoid instance.
243-- |Helper data structure used for composing patches using the monoid instance.
122−data Fixup k v a
244+data Fixup k p a
123 = Fixup_Delete
245 = Fixup_Delete
124− | Fixup_Update (These (From k v a) (To k a))
246+ | Fixup_Update (These (From k p a) (To k p a))
125−
247+
126−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
248+-- | Compose patches having the same effect as applying the patches in turn:
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
127−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
255+ ) => Semigroup (PatchDMapWithMove k p) where
128 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
256 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
129 where
257 where
258+ connections :: [DSum k (Pair1 (To k p) (From k p))]
259+ connections = DMap.toList $ DMap.intersectionWithKey
130− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
260+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
261+ ma
262+ mb
131− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
263+ h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
132− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
264+ h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
133− (Just toAfter, From_Move fromBefore)
265+ (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
134− | isJust $ fromBefore `geq` toAfter
266+ --case toAfter `geq` fromBefore of
267+ -- Just Refl | Just Refl <- Cat.isId p0 ->
135− -> [toAfter :=> Fixup_Delete]
268+ -- [ toAfter :=> Fixup_Delete ]
136− | otherwise
269+ -- _ ->
137− -> [ toAfter :=> Fixup_Update (This editBefore)
270+ [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
138− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
271+ , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
139− ]
272+ ]
273+ (To_NonMove, From_Move (fromBefore :=> _)) ->
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
274+ -- The item is destroyed in the second patch, so indicate that it is
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) ->
141− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
280+ [toAfter :=> Fixup_Update (This From_Delete)]
142− (Nothing, _) -> []
281+ (To_NonMove, _) ->
282+ []
143 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
283 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
144 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
284 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
145 | This x <- a, That y <- b
285 | This x <- a, That y <- b
@@ -170,13 +310,19 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
170 These _ b -> Just b
310 These _ b -> Just b
171 That b -> Just b
311 That b -> Just b
172
312
173−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
313+-- | Compose patches having the same effect as applying the patches in turn:
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
174−instance GCompare k => Monoid (PatchDMapWithMove k v) where
320+ ) => Monoid (PatchDMapWithMove k p) where
175 mempty = PatchDMapWithMove mempty
321 mempty = PatchDMapWithMove mempty
176 mappend = (<>)
322 mappend = (<>)
177
323
178{-
324{-
179−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
325+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
180PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
326PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
181 where
327 where
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
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
@@ -197,25 +343,31 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
343 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
198-}
344-}
199
345
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'.
346+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
347+-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
348+-- 'DMap.insert'.
201−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
349+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
202insertDMapKey k v =
350insertDMapKey k v =
203− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
351+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
204
352
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:
353+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value
354+-- from the first key @k a@ to the second key @k a@, equivalent to:
206--
355--
207-- @
356-- @
208-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
357-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
209-- @
358-- @
359+moveDMapKey
360+ :: GCompare k
210−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
361+ => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
211moveDMapKey src dst = case src `geq` dst of
362moveDMapKey src dst = case src `geq` dst of
212 Nothing -> PatchDMapWithMove $ DMap.fromList
363 Nothing -> PatchDMapWithMove $ DMap.fromList
213− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
364+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
214− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
365+ , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
215 ]
366 ]
216− Just _ -> mempty
367+ Just _ -> PatchDMapWithMove DMap.empty
217
368
218−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
369+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
370+-- in the mapping, equivalent to:
219--
371--
220-- @
372-- @
221-- let aMay = DMap.lookup a dmap
373-- let aMay = DMap.lookup a dmap
@@ -224,17 +376,18 @@ moveDMapKey src dst = case src `geq` dst of
224-- . maybe id (DMap.insert b) (aMay <> bMay)
376-- . maybe id (DMap.insert b) (aMay <> bMay)
225-- . DMap.delete a . DMap.delete b $ dmap
377-- . DMap.delete a . DMap.delete b $ dmap
226-- @
378-- @
227−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
379+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
228swapDMapKey src dst = case src `geq` dst of
380swapDMapKey src dst = case src `geq` dst of
229 Nothing -> PatchDMapWithMove $ DMap.fromList
381 Nothing -> PatchDMapWithMove $ DMap.fromList
230− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
382+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
231− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
383+ , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
232 ]
384 ]
233− Just _ -> mempty
385+ Just _ -> PatchDMapWithMove DMap.empty
234
386
235−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
387+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
388+-- the mapping, equivalent to 'DMap.delete'.
236deleteDMapKey :: k a -> PatchDMapWithMove k v
389deleteDMapKey :: k a -> PatchDMapWithMove k v
237−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
390+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
238
391
239{-
392{-
240k1, k2 :: Const2 Int () ()
393k1, k2 :: Const2 Int () ()
@@ -260,112 +413,217 @@ dst (PatchDMapWithMove x _) = x
260src (PatchDMapWithMove _ x) = x
413src (PatchDMapWithMove _ x) = x
261-}
414-}
262
415
263−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
416+-- | Extract the 'DMap' representing the patch changes from the
417+-- 'PatchDMapWithMove'.
264unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
418unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
265unPatchDMapWithMove (PatchDMapWithMove p) = p
419unPatchDMapWithMove (PatchDMapWithMove p) = p
266
420
267−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
421+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
422+-- without checking any invariants.
268--
423--
269-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
424-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
270unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
425unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
271unsafePatchDMapWithMove = PatchDMapWithMove
426unsafePatchDMapWithMove = PatchDMapWithMove
272
427
428+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while
273−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
429+-- checking invariants. If the invariants are satisfied, @Right p@ is returned
274-- otherwise @Left errors@.
430-- otherwise @Left errors@.
275−patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
431+patchDMapWithPatchingMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
276−patchDMapWithMove dm =
432+patchDMapWithPatchingMove dm =
277 case validationErrorsForPatchDMapWithMove dm of
433 case validationErrorsForPatchDMapWithMove dm of
278 [] -> Right $ unsafePatchDMapWithMove dm
434 [] -> Right $ unsafePatchDMapWithMove dm
279 errs -> Left errs
435 errs -> Left errs
280
436
281−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
437+-- | Map a natural transform @v -> v'@ over the given patch, transforming
438+-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
282−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
439+mapPatchDMapWithMove
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'
283−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
445+mapPatchDMapWithMove f g (PatchDMapWithMove m) =
446+ PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
284− DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
447+ { _nodeInfo_from = h $ _nodeInfo_from ni
448+ , _nodeInfo_to = j $ _nodeInfo_to ni
449+ }) m
285− where g :: forall a. From k v a -> From k v' a
450+ where h :: forall a. From k p a -> From k p' a
286− g = \case
451+ h = \case
287 From_Insert v -> From_Insert $ f v
452 From_Insert v -> From_Insert $ f v
288 From_Delete -> From_Delete
453 From_Delete -> From_Delete
289− From_Move k -> From_Move k
454+ From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
290−
455+ j :: forall a. To k p a -> To k p' a
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)@
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')@.
461+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
462+-- ('PatchDMapWithMove' k v')@.
292−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
463+traversePatchDMapWithMove
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')
293−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
470+traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
294−
471+ (\_ -> f)
472+ (\_ _ -> g)
473+
474+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
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')@.
475+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
476+-- ('PatchDMapWithMove' k v')@.
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')
477+traversePatchDMapWithMoveWithKey
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')
297−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
484+traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
485+ PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
486+ <$> h k (_nodeInfo_from ni)
487+ <*> j k (_nodeInfo_to ni)) m
298− where g :: forall a. k a -> From k v a -> m (From k v' a)
488+ where h :: forall a. k a -> From k p a -> m (From k p' a)
299− g k = \case
489+ h k = \case
300 From_Insert v -> From_Insert <$> f k v
490 From_Insert v -> From_Insert <$> f k v
301 From_Delete -> pure From_Delete
491 From_Delete -> pure From_Delete
302− From_Move fromKey -> pure $ From_Move fromKey
492+ From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
303−
493+ j :: forall a. k a -> To k p a -> m (To k p' a)
494+ j k = \case
495+ To_NonMove -> pure To_NonMove
496+ To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
497+
304−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
498+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
499+-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
305−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
500+nodeInfoMapFrom
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
306−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
506+ { _nodeInfo_from = f $ _nodeInfo_from ni
307−
507+ , _nodeInfo_to = g $ _nodeInfo_to ni
508+ }
509+
308−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
510+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
511+-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
309−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
512+nodeInfoMapFromM
513+ :: Applicative f
514+ => (From k p a -> f (From k p' a))
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
310−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
519+ <$> f (_nodeInfo_from ni)
311−
520+ <*> g (_nodeInfo_to ni)
521+
522+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithPatchingMove' by weakening the keys
312−-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
523+-- from @k a@ to @'Some' k@ and applying a given weakening function
313−-- values.
524+-- @PatchTarget1 p a -> v'@ to values.
314−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
525+weakenPatchDMapWithMoveWith
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'
315−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
531+weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
532+ PatchMapWithPatchingMove $ weakenDMapWith h m
316− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
533+ where h :: forall a. NodeInfo k p a -> MapWithPatchingMove.NodeInfo (Some k) p'
317− g ni = MapWithMove.NodeInfo
534+ h ni = MapWithPatchingMove.NodeInfo
318− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
535+ { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
319− From_Insert v -> MapWithMove.From_Insert $ f v
536+ From_Insert v -> MapWithPatchingMove.From_Insert $ f v
320− From_Delete -> MapWithMove.From_Delete
537+ From_Delete -> MapWithPatchingMove.From_Delete
321− From_Move k -> MapWithMove.From_Move $ mkSome k
538+ From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
322− , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
539+ , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
540+ To_NonMove -> Nothing
541+ To_Move (k :=> _) -> Just (mkSome k)
323 }
542 }
324
543
544+-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' k
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
545+-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
326−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
546+-- dependency in the typing and all points are already @a@, hence the function
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')
327−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
552+ -> PatchDMapWithMove (Const2 k a) p
328−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
553+ -> PatchMapWithPatchingMove k p'
554+patchDMapWithMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithMove m) =
555+ PatchMapWithPatchingMove $ dmapToMapWith h m
329− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
556+ where h :: NodeInfo (Const2 k a) p a -> MapWithPatchingMove.NodeInfo k p'
330− g ni = MapWithMove.NodeInfo
557+ h ni = MapWithPatchingMove.NodeInfo
331− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
558+ { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
332− From_Insert v -> MapWithMove.From_Insert $ f v
559+ From_Insert v -> MapWithPatchingMove.From_Insert $ f v
333− From_Delete -> MapWithMove.From_Delete
560+ From_Delete -> MapWithPatchingMove.From_Delete
334− From_Move (Const2 k) -> MapWithMove.From_Move k
561+ From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
335− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
562+ , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
563+ To_NonMove -> Nothing
564+ To_Move (Const2 k :=> _) -> Just k
336 }
565 }
337
566
567+-- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithMove
338−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
568+-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
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@.
569+-- dependently typed one but which always has a constant key type represented by
340−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
570+-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
571+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithPatchingMoveWith'
341−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
572+const2PatchDMapWithMoveWith
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) =
342−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
578+ PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
579+ where g :: (k, MapWithPatchingMove.NodeInfo k (Proxy v))
343− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
580+ -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
344 g (k, ni) = Const2 k :=> NodeInfo
581 g (k, ni) = Const2 k :=> NodeInfo
345− { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
582+ { _nodeInfo_from = case MapWithPatchingMove._nodeInfo_from ni of
346− MapWithMove.From_Insert v -> From_Insert $ f v
583+ MapWithPatchingMove.From_Insert v -> From_Insert $ f v
347− MapWithMove.From_Delete -> From_Delete
584+ MapWithPatchingMove.From_Delete -> From_Delete
348− MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
585+ MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
349− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
586+ , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
587+ Nothing -> To_NonMove
588+ Just toKey -> To_Move $ Const2 toKey :=> Proxy3
350 }
589 }
351
590
352-- | Apply the insertions, deletions, and moves to a given 'DMap'.
591-- | Apply the insertions, deletions, and moves to a given 'DMap'.
592+instance ( GCompare k
593+ , PatchHet2 p
594+ , PatchSource1 p ~ PatchTarget1 p
353−instance GCompare k => Patch (PatchDMapWithMove k v) where
595+ ) => PatchHet (PatchDMapWithMove k p) where
596+ type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
354− type PatchTarget (PatchDMapWithMove k v) = DMap k v
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
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?
603+ apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
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?
356− where insertions = DMap.mapMaybeWithKey insertFunc p
607+ where insertions = DMap.mapMaybeWithKey insertFunc m
357− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
608+ insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
358 insertFunc _ ni = case _nodeInfo_from ni of
609 insertFunc _ ni = case _nodeInfo_from ni of
359 From_Insert v -> Just v
610 From_Insert v -> Just v
360− From_Move k -> DMap.lookup k old
611+ From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
361 From_Delete -> Nothing
612 From_Delete -> Nothing
362− deletions = DMap.mapMaybeWithKey deleteFunc p
613+ deletions = DMap.mapMaybeWithKey deleteFunc m
363− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
614+ deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
364 deleteFunc _ ni = case _nodeInfo_from ni of
615 deleteFunc _ ni = case _nodeInfo_from ni of
365 From_Delete -> Just $ Constant ()
616 From_Delete -> Just $ Constant ()
366 _ -> Nothing
617 _ -> Nothing
367
618
368−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
619+-- | Get the values that will be replaced, deleted, or moved if the given patch
620+-- is applied to the given 'DMap'.
369−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
621+getDeletionsAndMoves
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))
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
628getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
371 where f _ v ni = Pair v $ _nodeInfo_to ni
629 where f _ v ni = Pair v $ _nodeInfo_to ni
src/Data/Patch/DMapWithMove/By.hsnew file+89
@@ -0,0 +1,89 @@
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+3−1
@@ -38,8 +38,10 @@ 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 Patch (PatchIntMap a) where
41+instance PatchHet (PatchIntMap a) where
42+ type PatchSource (PatchIntMap a) = IntMap a
42 type PatchTarget (PatchIntMap a) = IntMap a
43 type PatchTarget (PatchIntMap a) = IntMap a
44+instance Patch (PatchIntMap a) where
43 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
45 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
44 let removes = IntMap.filter isNothing p
46 let removes = IntMap.filter isNothing p
45 adds = IntMap.mapMaybe id p
47 adds = IntMap.mapMaybe id p
src/Data/Patch/Map.hs+3−1
@@ -45,8 +45,10 @@ 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 => Patch (PatchMap k v) where
48+instance Ord k => PatchHet (PatchMap k v) where
49+ type PatchSource (PatchMap k v) = Map k v
49 type PatchTarget (PatchMap k v) = Map k v
50 type PatchTarget (PatchMap k v) = Map k v
51+instance Ord k => Patch (PatchMap k v) where
50 {-# INLINABLE apply #-}
52 {-# INLINABLE apply #-}
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?
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?
52 where insertions = Map.mapMaybeWithKey (const id) p
54 where insertions = Map.mapMaybeWithKey (const id) p
src/Data/Patch/MapWithMove.hs+11−8
@@ -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 PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
140+patchMapWithMove = fmap coerce . 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,11 +175,14 @@ 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 = coerce PM.unsafePatchMapWithPatchingMove
178+unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
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 => Patch (PatchMapWithMove k v) where
181+instance Ord k => PatchHet (PatchMapWithMove k v) where
182+ type PatchSource (PatchMapWithMove k v) = Map k v
182 type PatchTarget (PatchMapWithMove k v) = Map k v
183 type PatchTarget (PatchMapWithMove k v) = Map k v
184+
185+instance Ord k => Patch (PatchMapWithMove k v) where
183 apply (PatchMapWithMove' p) = apply p
186 apply (PatchMapWithMove' p) = apply p
184
187
185-- | Returns all the new elements that will be added to the 'Map'.
188-- | Returns all the new elements that will be added to the 'Map'.
@@ -199,7 +202,7 @@ patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
202-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
200-- will produce a 'Map' with the same values as the second 'Map' but with the
203-- will produce a 'Map' with the same values as the second 'Map' but with the
201-- values sorted with the given ordering function.
204-- values sorted with the given ordering function.
202−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
205+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
206patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204 where newList = Map.toList newByIndexUnsorted
207 where newList = Map.toList newByIndexUnsorted
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
208 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
@@ -255,13 +258,13 @@ bitraverseNodeInfo
255 => (k0 -> f k1)
258 => (k0 -> f k1)
256 -> (v0 -> f v1)
259 -> (v0 -> f v1)
257 -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
260 -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258−bitraverseNodeInfo fk fv = fmap NodeInfo'
261+bitraverseNodeInfo fk fv = fmap coerce
259 . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
262 . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260 . coerce
263 . coerce
261
264
262-- | Change the 'From' value of a 'NodeInfo'
265-- | Change the 'From' value of a 'NodeInfo'
263nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
266nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
264−nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
267+nodeInfoMapFrom f = coerce . PM.nodeInfoMapFrom (unFrom' . f . From') . coerce
265
268
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
269-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
267-- 'Applicative', 'Monad', etc.) action to get the new value
270-- 'Applicative', 'Monad', etc.) action to get the new value
@@ -269,7 +272,7 @@ nodeInfoMapMFrom
269 :: Functor f
272 :: Functor f
270 => (From k v -> f (From k v))
273 => (From k v -> f (From k v))
271 -> NodeInfo k v -> f (NodeInfo k v)
274 -> NodeInfo k v -> f (NodeInfo k v)
272−nodeInfoMapMFrom f = fmap NodeInfo'
275+nodeInfoMapMFrom f = fmap coerce
273 . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
276 . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274 . coerce
277 . coerce
275
278
@@ -303,7 +306,7 @@ bitraverseFrom
303 => (k0 -> f k1)
306 => (k0 -> f k1)
304 -> (v0 -> f v1)
307 -> (v0 -> f v1)
305 -> From k0 v0 -> f (From k1 v1)
308 -> From k0 v0 -> f (From k1 v1)
306−bitraverseFrom fk fv = fmap From'
309+bitraverseFrom fk fv = fmap coerce
307 . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
310 . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308 . coerce
311 . coerce
309
312
src/Data/Patch/MapWithPatchingMove.hs+38−36
@@ -48,10 +48,10 @@ module Data.Patch.MapWithPatchingMove
48
48
49import Data.Patch.Class
49import Data.Patch.Class
50
50
51−import Control.Lens hiding (from, to)
51+import Control.Arrow
52import Control.Lens.TH (makeWrapped)
52import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
53+import Control.Monad.Trans.State
54−import Data.Foldable (toList)
54+import Data.Foldable
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)
65import qualified Data.Set as Set
64import qualified Data.Set as Set
66import Data.These (These (..))
65import 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,8 +170,11 @@ 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) => Patch (PatchMapWithPatchingMove k p) where
173+instance (Ord k, Patch p) => PatchHet (PatchMapWithPatchingMove k p) where
174+ type PatchSource (PatchMapWithPatchingMove k p) = Map k (PatchSource p)
174 type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
175 type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
176+
177+instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
175 -- TODO: return Nothing sometimes
178 -- TODO: return Nothing sometimes
176 -- Note: the strict application here is critical to ensuring that incremental
179 -- Note: the strict application here is critical to ensuring that incremental
177 -- merges don't hold onto all their prerequisite events forever; can we make
180 -- merges don't hold onto all their prerequisite events forever; can we make
@@ -229,40 +232,39 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
229
232
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
233-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231-- will produce the second 'Map'.
234-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233patchThatChangesMap
235patchThatChangesMap
234− :: forall k p
235− . (Ord k, Ord (PatchTarget p), Monoid p)
236+ :: (Ord k, Ord (PatchTarget p), Monoid p)
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237patchThatChangesMap oldByIndex newByIndex = patch
238patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
239+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
240+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
241+ let f k v = do
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
242+ remainingValues <- get
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
243+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
243− unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
244+ then Map.delete v remainingValues
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
245+ else Map.insert v remainingKeys remainingValues
245− -- Generate patch info for a single value
246+ case Map.lookup v remainingValues of
246− -- Keys that are found in both the old and new sets will not be patched
247+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
247− -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
248+ Just fromKs ->
248− -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
249+ if k `Set.member` fromKs
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
250+ then do
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
251+ putRemainingKeys $ Set.delete k fromKs
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
252+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
252− That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
253+ else do
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
254+ (fromK, remainingKeys) <- return $
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
255+ fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
256+ Set.minView fromKs -- There's an existing value, but it's not here; move it here
256− patchSingleValueThese v = \case
257+ putRemainingKeys remainingKeys
257− This oldKeys -> patchSingleValue v oldKeys mempty
258+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
258− That newKeys -> patchSingleValue v mempty newKeys
259+ Map.traverseWithKey f newByIndex
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
260+ unusedOldKeys = fold unusedValuesByValue
260− -- Generate froms and tos for all values, then merge them together
261+ pointlessMove k = \case
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
262+ From_Move k' _ | k == k' -> True
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
263+ _ -> False
263− This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
264+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
265+ then Just undefined
265− These from to -> NodeInfo from to
266+ else Nothing
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
266
268
267--
269--
268-- NodeInfo
270-- NodeInfo
src/Data/Semigroup/Additive.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
4−-- |
5−-- Module:
6−-- Data.Semigroup.Additive
7−-- Description:
8−-- This module defines a class for commutative semigroups, until it is moved
9−-- to another library.
10−module Data.Semigroup.Additive
11− ( Additive
12− ) where
13−
14−import Data.Functor.Const (Const (..))
15−import Data.Functor.Identity
16−import Data.Proxy
17−#if !MIN_VERSION_base(4,12,0)
18−-- for :*: and :.: semigroup instances
19−import Data.Orphans ()
20−#endif
21−#if !MIN_VERSION_base(4,11,0)
22−import Data.Semigroup (Semigroup (..))
23−#endif
24−import GHC.Generics
25−
26−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
27−class Semigroup q => Additive q where
28−
29−-- | Trivial additive semigroup.
30−instance Additive ()
31−
32−-- | Product additive semigroup.
33−-- A Pair of additive semigroups gives rise to a additive semigroup
34−instance (Additive a, Additive b) => Additive (a, b)
35−
36−-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
37−-- Base does not define Monoid (Compose f g a) so this is the best we can
38−-- really do for functor composition.
39−instance Additive (f (g a)) => Additive ((f :.: g) a)
40−
41−-- | Product of additive semigroups, Functor style.
42−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
43−
44−-- | Trivial additive semigroup, Functor style
45−instance Additive (Proxy x)
46−
47−-- | Const lifts additive semigroups into a functor.
48−instance Additive a => Additive (Const a x)
49−
50−-- | Identity lifts additive semigroups pointwise (at only one point)
51−instance Additive a => Additive (Identity a)
52−
53−-- | Functions lift additive semigroups pointwise.
54−instance Additive b => Additive (a -> b)
test/tests.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−module Main where
3−
4−import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)
5−import Data.Patch ( Patch(apply) )
6−import Data.Patch.MapWithMove ( patchThatChangesMap )
7−import Data.Map as Map ( Map, fromList, singleton )
8−import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))
9−import Hedgehog.Gen as Gen ( int )
10−import Hedgehog.Range as Range ( linear )
11−import Control.Monad (replicateM)
12−import System.Exit (exitFailure, exitSuccess)
13−import Data.Sequence as Seq ( foldMapWithIndex, replicateM )
14−
15−main :: IO ()
16−main = do
17− counts <- runTestTT $ test [
18− "Simple Move" ~: (do
19− let mapBefore = Map.fromList [(0,1)]
20− mapAfter = Map.fromList [(0,0),(1,1)]
21− patch = patchThatChangesMap mapBefore mapAfter
22− afterPatch = apply patch mapBefore
23− assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),
24− "Property Checks" ~: propertyChecks
25− ]
26− if errors counts + failures counts == 0 then exitSuccess else exitFailure
27−
28−propertyChecks :: IO Bool
29−propertyChecks = checkParallel $$(discover)
30−
31−prop_patchThatChangesMap :: Property
32−prop_patchThatChangesMap = property $ do
33− mapBefore <- makeRandomIntMap
34− mapAfter <- makeRandomIntMap
35− let patch = patchThatChangesMap mapBefore mapAfter
36− Just mapAfter === apply patch mapBefore
37−
38−makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)
39−makeRandomIntMap = do
40− let genNum = Gen.int (Range.linear 0 100)
41− length <- forAll genNum
42− listOfNumbers <- forAll $ Seq.replicateM length genNum
43− pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers