on 6ef716a help sign in
ChangeLog.md+4
since splitsnapshots
unifiedsplit
@@ -2,6 +2,10 @@
2
2
3## Unreleased
3## Unreleased
4
4
5+* `PatchMapWithMove` supports moves with a patch.
6+
7+* `PatchDMapWithMove` supports moves with a patch.
8+
5* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
9* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
6 Care is taken to make this not a breaking change.
10 Care is taken to make this not a breaking change.
7 In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
11 In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
patch.cabal+4−1
@@ -43,12 +43,14 @@ library
43 , transformers >= 0.5.6.0 && < 0.6
43 , transformers >= 0.5.6.0 && < 0.6
44 , witherable >= 0.3 && < 0.4
44 , witherable >= 0.3 && < 0.4
45
45
46+ exposed-modules: Control.Category.DecidablyEmpty
46− exposed-modules: Data.Functor.Misc
47+ , Data.Functor.Misc
47 , Data.Monoid.DecidablyEmpty
48 , Data.Monoid.DecidablyEmpty
48 , Data.Patch
49 , Data.Patch
49 , Data.Patch.Class
50 , Data.Patch.Class
50 , Data.Patch.DMap
51 , Data.Patch.DMap
51 , Data.Patch.DMapWithMove
52 , Data.Patch.DMapWithMove
53+ , Data.Patch.DMapWithMove.By
52 , Data.Patch.IntMap
54 , Data.Patch.IntMap
53 , Data.Patch.Map
55 , Data.Patch.Map
54 , Data.Patch.MapWithMove
56 , Data.Patch.MapWithMove
@@ -59,6 +61,7 @@ library
59
61
60 if flag(split-these)
62 if flag(split-these)
61 build-depends: these >= 1 && <1.2
63 build-depends: these >= 1 && <1.2
64+ , these-lens >= 1 && <1.1
62 , semialign >=1 && <1.2
65 , semialign >=1 && <1.2
63 , monoidal-containers >= 0.6 && < 0.7
66 , monoidal-containers >= 0.6 && < 0.7
64 else
67 else
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+8−6
@@ -27,7 +27,7 @@ import Data.Patch.Class as X
27import Data.Patch.DMap as X hiding (getDeletions)
27import Data.Patch.DMap as X hiding (getDeletions)
28import Data.Patch.DMapWithMove as X
28import Data.Patch.DMapWithMove as X
29 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
29 ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
30− , patchDMapWithMoveToPatchMapWithMoveWith
30+ , patchDMapWithMoveToPatchMapWithPatchingMoveWith
31 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
31 , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
32 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
32 , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
33 )
33 )
@@ -51,8 +51,10 @@ class Semigroup q => Additive q where
51-- | 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.
52newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
52newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
53
53
54−instance Additive p => Patch (AdditivePatch p) where
54+instance Additive p => PatchHet (AdditivePatch p) where
55+ type PatchSource (AdditivePatch p) = p
55 type PatchTarget (AdditivePatch p) = p
56 type PatchTarget (AdditivePatch p) = p
57+instance Additive p => Patch (AdditivePatch p) where
56 apply (AdditivePatch p) q = Just $ p <> q
58 apply (AdditivePatch p) q = Just $ p <> q
57
59
58instance (Ord k, Group q) => Group (MonoidalMap k q) where
60instance (Ord k, Group q) => Group (MonoidalMap k q) where
@@ -62,8 +64,8 @@ instance (Ord k, Additive q) => Additive (MonoidalMap k q)
62
64
63-- | Trivial group.
65-- | Trivial group.
64instance Group () where
66instance Group () where
65− negateG _ = ()
67+ negateG ~() = ()
66− _ ~~ _ = ()
68+ ~() ~~ ~() = ()
67instance Additive ()
69instance Additive ()
68
70
69-- | Product group. A Pair of groups gives rise to a group
71-- | Product group. A Pair of groups gives rise to a group
@@ -88,8 +90,8 @@ instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
88
90
89-- | Trivial group, Functor style
91-- | Trivial group, Functor style
90instance Group (Proxy x) where
92instance Group (Proxy x) where
91− negateG _ = Proxy
93+ negateG ~Proxy = Proxy
92− _ ~~ _ = Proxy
94+ ~Proxy ~~ ~Proxy = Proxy
93instance Additive (Proxy x)
95instance Additive (Proxy x)
94
96
95-- | Const lifts groups into a functor.
97-- | Const lifts groups into a functor.
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+4−1
@@ -178,8 +178,11 @@ unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
178unsafePatchMapWithMove = 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'.
src/Data/Patch/MapWithPatchingMove.hs+4−1
@@ -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