on 08f13f2 help sign in
ChangeLog.md+2
since splitsnapshots
unifiedsplit
@@ -4,6 +4,8 @@
4
4
5* `PatchMapWithMove` supports moves with a patch.
5* `PatchMapWithMove` supports moves with a patch.
6
6
7+* `PatchDMapWithMove` supports moves with a patch.
8+
7## 0.0.1.0
9## 0.0.1.0
8
10
9* Support older GHCs with `split-these` flag.
11* Support older GHCs with `split-these` flag.
patch.cabal+5−1
@@ -39,11 +39,14 @@ library
39 , transformers >= 0.5.6.0 && < 0.6
39 , transformers >= 0.5.6.0 && < 0.6
40 , witherable >= 0.3 && < 0.3.2
40 , witherable >= 0.3 && < 0.3.2
41
41
42+ exposed-modules: Control.Category.DecidablyEmpty
42− exposed-modules: Data.Functor.Misc
43+ , Data.Functor.Misc
44+ , Data.Monoid.DecidablyEmpty
43 , Data.Patch
45 , Data.Patch
44 , Data.Patch.Class
46 , Data.Patch.Class
45 , Data.Patch.DMap
47 , Data.Patch.DMap
46 , Data.Patch.DMapWithMove
48 , Data.Patch.DMapWithMove
49+ , Data.Patch.DMapWithMove.By
47 , Data.Patch.IntMap
50 , Data.Patch.IntMap
48 , Data.Patch.Map
51 , Data.Patch.Map
49 , Data.Patch.MapWithMove
52 , Data.Patch.MapWithMove
@@ -52,6 +55,7 @@ library
52
55
53 if flag(split-these)
56 if flag(split-these)
54 build-depends: these >= 1 && <1.1
57 build-depends: these >= 1 && <1.1
58+ , these-lens >= 1 && <1.1
55 , semialign >=1 && <1.2
59 , semialign >=1 && <1.2
56 , monoidal-containers >= 0.6 && < 0.7
60 , monoidal-containers >= 0.6 && < 0.7
57 else
61 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 #-}
@@ -17,6 +17,8 @@
17module Data.Functor.Misc
17module Data.Functor.Misc
18 ( -- * Const2
18 ( -- * Const2
19 Const2 (..)
19 Const2 (..)
20+ , Proxy3 (..)
21+ , First2 (..)
20 , unConst2
22 , unConst2
21 , dmapToMap
23 , dmapToMap
22 , dmapToIntMap
24 , dmapToIntMap
@@ -37,6 +39,7 @@ module Data.Functor.Misc
37 , ComposeMaybe (..)
39 , ComposeMaybe (..)
38 ) where
40 ) where
39
41
42+import qualified Control.Category as Cat
40import Control.Applicative ((<$>))
43import Control.Applicative ((<$>))
41import Data.Dependent.Map (DMap)
44import Data.Dependent.Map (DMap)
42import qualified Data.Dependent.Map as DMap
45import qualified Data.Dependent.Map as DMap
@@ -48,6 +51,7 @@ import Data.IntMap (IntMap)
48import qualified Data.IntMap as IntMap
51import qualified Data.IntMap as IntMap
49import Data.Map (Map)
52import Data.Map (Map)
50import qualified Data.Map as Map
53import qualified Data.Map as Map
54+import qualified Data.Semigroupoid as Cat
51import Data.Some (Some(Some))
55import Data.Some (Some(Some))
52import Data.These
56import Data.These
53import Data.Type.Equality ((:~:)(Refl))
57import Data.Type.Equality ((:~:)(Refl))
@@ -63,15 +67,15 @@ data Const2 :: * -> x -> x -> * where
63 Const2 :: k -> Const2 k v v
67 Const2 :: k -> Const2 k v v
64 deriving (Typeable)
68 deriving (Typeable)
65
69
66−-- | Extract the value from a Const2
67−unConst2 :: Const2 k v v' -> k
68−unConst2 (Const2 k) = k
69−
70deriving instance Eq k => Eq (Const2 k v v')
70deriving instance Eq k => Eq (Const2 k v v')
71deriving instance Ord k => Ord (Const2 k v v')
71deriving instance Ord k => Ord (Const2 k v v')
72deriving instance Show k => Show (Const2 k v v')
72deriving instance Show k => Show (Const2 k v v')
73deriving instance Read k => Read (Const2 k v v)
73deriving instance Read k => Read (Const2 k v v)
74
74
75+-- | Extract the value from a Const2
76+unConst2 :: Const2 k v v' -> k
77+unConst2 (Const2 k) = k
78+
75instance Show k => GShow (Const2 k v) where
79instance Show k => GShow (Const2 k v) where
76 gshowsPrec n x@(Const2 _) = showsPrec n x
80 gshowsPrec n x@(Const2 _) = showsPrec n x
77
81
@@ -87,6 +91,25 @@ instance Ord k => GCompare (Const2 k v) where
87 EQ -> GEQ
91 EQ -> GEQ
88 GT -> GGT
92 GT -> GGT
89
93
94+data Proxy3 :: x -> y -> z -> * where
95+ Proxy3 :: Proxy3 vx vy vz
96+ deriving ( Show, Read, Eq, Ord
97+ , Functor, Foldable, Traversable
98+ , Typeable
99+ )
100+
101+instance Cat.Category (Proxy3 x) where
102+ id = Proxy3
103+ ~Proxy3 . ~Proxy3 = Proxy3
104+
105+newtype First2 (t :: k -> *) (a :: k) (b :: k) = First2 (t b)
106+ deriving ( Show, Read, Eq, Ord
107+ , Functor, Foldable, Traversable
108+ )
109+
110+instance Cat.Semigroupoid (First2 x) where
111+ First2 x `o` ~(First2 _) = First2 x
112+
90-- | Convert a 'DMap' to a regular 'Map'
113-- | Convert a 'DMap' to a regular 'Map'
91dmapToMap :: DMap (Const2 k v) Identity -> Map k v
114dmapToMap :: DMap (Const2 k v) Identity -> Map k v
92dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
115dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
src/Data/Patch.hs+7−5
@@ -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+132−6
@@ -1,18 +1,53 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE DerivingStrategies #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PolyKinds #-}
1{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
2-- | The interface for types which represent changes made to other types
9-- | The interface for types which represent changes made to other types
3module Data.Patch.Class where
10module Data.Patch.Class where
4
11
12+import qualified Data.Semigroupoid as Cat
5import Data.Functor.Identity
13import Data.Functor.Identity
14+import Data.Functor.Misc
6import Data.Maybe
15import Data.Maybe
7import Data.Semigroup (Semigroup(..))
16import Data.Semigroup (Semigroup(..))
8import Data.Proxy
17import Data.Proxy
18+import Data.Type.Equality ((:~:) (..))
19+
20+class PatchHet p where
21+ type PatchSource p :: *
22+ type PatchTarget p :: *
23+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
24+ -- 'Nothing'.
25+ applyHet
26+ :: p
27+ -> PatchSource p
28+ -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
29+ default applyHet
30+ :: Patch p
31+ => p
32+ -> PatchSource p
33+ -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
34+ applyHet p a = case apply p a of
35+ Nothing -> Left Refl
36+ Just a' -> Right a'
37+
38+-- | Apply a 'PatchHet'; if it does nothing, return the original value
39+applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
40+applyAlwaysHet p t = case applyHet p t of
41+ Left Refl -> t
42+ Right t' -> t'
9
43
10-- | A 'Patch' type represents a kind of change made to a datastructure.
44-- | A 'Patch' type represents a kind of change made to a datastructure.
11--
45--
12-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
46-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
13-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
47-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
48+class ( PatchHet p
49+ , PatchSource p ~ PatchTarget p
14−class Patch p where
50+ ) => Patch p where
15− type PatchTarget p :: *
16 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
51 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
17 -- 'Nothing'.
52 -- 'Nothing'.
18 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
53 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -22,19 +57,110 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
22applyAlways p t = fromMaybe t $ apply p t
57applyAlways p t = fromMaybe t $ apply p t
23
58
24-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
59-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
25−instance Patch (Identity a) where
60+instance PatchHet (Identity a) where
61+ type PatchSource (Identity a) = a
26 type PatchTarget (Identity a) = a
62 type PatchTarget (Identity a) = a
63+instance Patch (Identity a) where
27 apply (Identity a) _ = Just a
64 apply (Identity a) _ = Just a
28
65
29−-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
66+-- | 'Proxy' can be used as a 'Patch' that always fully replaces the value
30−instance Patch (Proxy a) where
67+instance PatchHet (Proxy (a :: *)) where
68+ type PatchSource (Proxy a) = a
31 type PatchTarget (Proxy a) = a
69 type PatchTarget (Proxy a) = a
70+instance Patch (Proxy (a :: *)) where
32 apply ~Proxy _ = Nothing
71 apply ~Proxy _ = Nothing
33
72
34-- | Like '(.)', but composes functions that return patches rather than
73-- | Like '(.)', but composes functions that return patches rather than
35-- functions that return new values. The Semigroup instance for patches must
74-- functions that return new values. The Semigroup instance for patches must
36-- apply patches right-to-left, like '(.)'.
75-- apply patches right-to-left, like '(.)'.
37−composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
76+composePatchFunctions
77+ :: (Patch p, Semigroup p)
78+ => (PatchTarget p -> p)
79+ -> (PatchTarget p -> p)
80+ -> PatchTarget p -> p
38composePatchFunctions g f a =
81composePatchFunctions g f a =
39 let fp = f a
82 let fp = f a
40 in g (applyAlways fp a) <> fp
83 in g (applyAlways fp a) <> fp
84+
85+
86+class PatchHet2Base (p :: k -> k -> *) where
87+ type PatchSource1 p :: k -> *
88+ type PatchTarget1 p :: k -> *
89+
90+class ( PatchHet2Base p
91+ , PatchHet (p from to)
92+ , PatchSource1 p from ~ PatchSource (p from to)
93+ , PatchTarget1 p to ~ PatchTarget (p from to)
94+ ) => PatchHet2Locally (p :: k -> k -> *) from to where
95+instance ( 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+
101+applyHet2Locally
102+ :: PatchHet2Locally p from to
103+ => p from to
104+ -> PatchSource1 p from
105+ -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
106+applyHet2Locally = applyHet
107+
108+applyAlwaysHet2Locally
109+ :: PatchHet2Locally p from to
110+ => p from to
111+ -> PatchSource1 p from
112+ -> PatchTarget1 p to
113+applyAlwaysHet2Locally = applyAlwaysHet
114+
115+-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
116+-- PatchHet2Locally, or at least get rid of this.
117+class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where
118+ applyHet2
119+ :: p from to
120+ -> PatchSource1 p from
121+ -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
122+
123+applyAlwaysHet2
124+ :: PatchHet2 p
125+ => p from to
126+ -> PatchSource1 p from
127+ -> PatchTarget1 p to
128+applyAlwaysHet2 p t = case applyHet2 p t of
129+ Left Refl -> t
130+ Right t' -> t'
131+
132+-- | Connect the classes without quanitified constraints
133+newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
134+ deriving newtype Cat.Semigroupoid
135+
136+instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
137+ type PatchSource (ProjectLocal p from to) = PatchSource1 p from
138+ type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
139+ applyHet (ProjectLocal p) = applyHet2 p
140+
141+instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
142+ type PatchSource1 (ProjectLocal p) = PatchSource1 p
143+ type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
144+
145+class ( PatchHet2Base p
146+ , PatchSource1 p ~ PatchTarget1 p
147+ ) => Patch2 p
148+instance ( PatchHet2Base p
149+ , PatchSource1 p ~ PatchTarget1 p
150+ ) => Patch2 p
151+
152+-- | 'First2' can be used as a 'Patch' that always fully replaces the value
153+instance PatchHet (First2 (t :: k -> *) (from :: k) (to :: k)) where
154+ type PatchSource (First2 t from to) = t from
155+ type PatchTarget (First2 t from to) = t to
156+ applyHet (First2 val) _ = Right val
157+
158+-- | 'Proxy3' can be used as a 'Patch' that always does nothing
159+instance PatchHet (Proxy3 (t :: k -> *) (a :: k) (a :: k)) where
160+ type PatchSource (Proxy3 t a a) = t a
161+ type PatchTarget (Proxy3 t a a) = t a
162+ applyHet ~Proxy3 _ = Left Refl
163+
164+instance PatchHet2Base (Proxy3 (t :: k -> *) :: k -> k -> *) where
165+ type PatchSource1 (Proxy3 t) = t
166+ type PatchTarget1 (Proxy3 t) = t
src/Data/Patch/DMap.hs+3−1
@@ -31,8 +31,10 @@ deriving instance GCompare k => Semigroup (PatchDMap k v)
31deriving instance GCompare k => Monoid (PatchDMap k v)
31deriving instance GCompare k => Monoid (PatchDMap k v)
32
32
33-- | Apply the insertions or deletions to a given 'DMap'.
33-- | Apply the insertions or deletions to a given 'DMap'.
34−instance GCompare k => Patch (PatchDMap k v) where
34+instance GCompare k => PatchHet (PatchDMap k v) where
35+ type PatchSource (PatchDMap k v) = DMap k v
35 type PatchTarget (PatchDMap k v) = DMap k v
36 type PatchTarget (PatchDMap k v) = DMap k v
37+instance GCompare k => Patch (PatchDMap k v) where
36 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?
38 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?
37 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
39 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
38 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
40 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
src/Data/Patch/DMapWithMove.hs+405−152
@@ -1,101 +1,222 @@
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−
22−import Data.Constraint.Extras
24+import Data.Constraint.Extras (Has')
23−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
25+import Data.Dependent.Map (DMap)
26+import Data.Dependent.Sum (DSum (..))
24import qualified Data.Dependent.Map as DMap
27import qualified Data.Dependent.Map as DMap
25−import Data.Functor.Constant
28+import Data.Functor.Constant (Constant (..))
26import Data.Functor.Misc
29import Data.Functor.Misc
30+ ( Const2 (..), Proxy3 (..)
31+ , weakenDMapWith
32+ , dmapToMapWith
33+ )
27−import Data.Functor.Product
34+import Data.Functor.Product (Product (..))
28−import Data.GADT.Compare (GEq (..))
35+import Data.GADT.Compare (GEq (..), GCompare (..))
29−import Data.GADT.Show (GShow, gshow)
36+import Data.GADT.Show (GRead, GShow, gshow)
30import qualified Data.Map as Map
37import qualified Data.Map as Map
31import Data.Maybe
38import Data.Maybe
32import Data.Semigroup (Semigroup (..), (<>))
39import Data.Semigroup (Semigroup (..), (<>))
40+import Data.Semigroupoid as Cat
33import Data.Some (Some(Some))
41import Data.Some (Some(Some))
34−import Data.Proxy
42+import Data.Proxy (Proxy (..))
35−import Data.These
43+import Data.These (These (..))
36
44
45+import Data.Patch.Class
46+ ( Patch (..), PatchHet (..)
47+ , PatchHet2 (..), PatchSource1, PatchTarget1
48+ , applyAlwaysHet2
49+ )
50+import Data.Patch.MapWithMove (PatchMapWithMove (..))
51+import qualified Data.Patch.MapWithMove as MapWithMove
52+
53+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'
37−-- | 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
54+-- which describes how it will be changed by the patch and connects move sources
38−-- destinations.
55+-- and destinations.
39--
56--
40-- Invariants:
57-- Invariants:
41--
58--
42−-- * A key should not move to itself.
59+-- * A key should not move to itself.
60+--
43−-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
61+-- * A move should always be represented with both the destination key (as a
62+-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'
63+-- destination)@)
44newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
64newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
45
65
66+--deriving instance ( GShow k
67+-- , HasZip Show k p
68+-- , Has' Show k (PatchTarget1 p)
69+-- ) => Show (PatchDMapWithMove k p)
70+--deriving instance ( GRead k
71+-- , HasZip Read k p
72+-- , Has' Read k (PatchTarget1 p)
73+-- ) => Read (PatchDMapWithMove k p)
74+--deriving instance ( GEq k
75+-- , HasZip Eq k p
76+-- , Has' Eq k (PatchTarget1 p)
77+-- ) => Eq (PatchDMapWithMove k p)
78+--deriving instance ( GCompare k
79+-- , HasZip Ord k p
80+-- , Has' Ord k (PatchTarget1 p)
81+-- ) => Ord (PatchDMapWithMove k p)
82+
83+-- | Structure which represents what changes apply to a particular key.
46−-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
84+-- @_nodeInfo_from@ specifies what happens to this key, and in particular what
47−-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
85+-- other key the current key is moving from, while @_nodeInfo_to@ specifies what
86+-- key the current key is moving to if involved in a move.
48−data NodeInfo k v a = NodeInfo
87+data NodeInfo k p a = NodeInfo
49− { _nodeInfo_from :: !(From k v a)
88+ { _nodeInfo_from :: !(From k p a)
50− -- ^Change applying to the current key, be it an insert, move, or delete.
89+ -- ^ Change applying to the current key, be it an insert, move, or delete.
51− , _nodeInfo_to :: !(To k a)
90+ , _nodeInfo_to :: !(To k p a)
52− -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
91+ -- ^ Where this key is moving to, if involved in a move. Should only be
92+ -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
53 }
93 }
94+
54− deriving (Show)
95+--deriving instance ( Show (k a)
55−
96+-- , Show (p a a)
97+-- , Show (PatchTarget1 p a)
98+-- ) => Show (NodeInfo k p a)
99+--deriving instance ( Read (k a)
100+-- , Read (p a a)
101+-- , Read (PatchTarget1 p a)
102+-- ) => Read (NodeInfo k p a)
103+--deriving instance ( Eq (k a)
104+-- , Eq (p a a)
105+-- , Eq (PatchTarget1 p a)
106+-- ) => Eq (NodeInfo k p a)
107+--deriving instance ( Ord (k a)
108+-- , Ord (p a a)
109+-- , Ord (PatchTarget1 p a)
110+-- ) => Ord (NodeInfo k p a)
111+
56−-- |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
112+-- | Structure describing a particular change to a key, be it inserting a new
113+-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
57−-- key (@From_Delete@), or moving a key (@From_Move@).
114+-- a key (@From_Delete@), or moving a key (@From_Move@).
115+--
116+-- This type isn't used directly as the from field patch, but is instead wrapped
117+-- in an existential. However, it is nice to be able to reason about this in
118+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
58−data From (k :: a -> *) (v :: a -> *) :: a -> * where
119+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
59− -- |Insert a new or update an existing key with the given value @v a@
120+ -- | Insert a new or update an existing key with the given value @PatchTarget1
121+ -- p a@
60− From_Insert :: v a -> From k v a
122+ From_Insert :: PatchTarget1 p to -> From k p to
61− -- |Delete the existing key
123+ -- | Delete the existing key
62− From_Delete :: From k v a
124+ From_Delete :: From k p to
125+ -- | Move the value from the given key @k a@ to this key. The source key
63− -- |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@,
126+ -- should also have an entry in the patch giving the current key as
64− -- usually but not necessarily with @From_Delete@.
127+ -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
65− From_Move :: !(k a) -> From k v a
128+ From_Move :: !(DSum k (Flip p to)) -> From k p to
66− deriving (Show, Read, Eq, Ord)
129+
67−
130+deriving instance ( Show (k a), GShow k
68−-- |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
131+ , Has' Show k (Flip p a)
69−-- operation.
132+ , Show (PatchTarget1 p a)
70−type To = ComposeMaybe
133+ ) => Show (From k p a)
134+deriving instance ( Read (k a), GRead k
135+ , Has' Read k (Flip p a)
136+ , Read (PatchTarget1 p a)
137+ ) => Read (From k p a)
138+deriving instance ( GEq k
139+ , Has' Eq k (Flip p a)
140+ , Eq (PatchTarget1 p a)
141+ ) => Eq (From k p a)
142+deriving instance ( GCompare k
143+ , Has' Eq k (Flip p a) -- superclass bug
144+ , Has' Ord k (Flip p a)
145+ , Ord (PatchTarget1 p a)
146+ ) => Ord (From k p a)
147+
148+newtype Flip p to from = Flip (p from to)
149+
150+instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
151+ id = Flip Cat.id
152+ Flip y . Flip x = Flip $ x Cat.. y
153+
154+-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
155+-- is, we store just the information necessary to compose a @To@ and @From@ like
156+-- @oLocal@ composes two @From@s.
157+data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
158+ -- | Delete or leave in place
159+ To_NonMove :: To k p from
160+ -- | Move the value from the given key @k a@ to this key. The target key
161+ -- should also have an entry in the patch giving the current key in
162+ -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
163+ To_Move :: !(DSum k (p from)) -> To k p from
164+
165+deriving instance ( Show (k a), GShow k
166+ , Has' Show k (p a)
167+ , Show (PatchTarget1 p a)
168+ ) => Show (To k p a)
169+deriving instance ( Read (k a), GRead k
170+ , Has' Read k (p a)
171+ , Read (PatchTarget1 p a)
172+ ) => Read (To k p a)
173+deriving instance ( GEq k
174+ , Has' Eq k (p a)
175+ , Eq (PatchTarget1 p a)
176+ ) => Eq (To k p a)
177+deriving instance ( GCompare k
178+ , Has' Eq k (p a) -- superclass bug
179+ , Has' Ord k (p a)
180+ , Ord (PatchTarget1 p a)
181+ ) => Ord (To k p a)
71
182
72-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
183-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
73−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
184+validPatchDMapWithMove
185+ :: forall k v
186+ . (GCompare k, GShow k)
187+ => DMap k (NodeInfo k v)
188+ -> Bool
74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
189validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
75
190
76-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
191-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
77−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
192+validationErrorsForPatchDMapWithMove
193+ :: forall k v
194+ . (GCompare k, GShow k)
195+ => DMap k (NodeInfo k v)
196+ -> [String]
78validationErrorsForPatchDMapWithMove m =
197validationErrorsForPatchDMapWithMove m =
79 noSelfMoves <> movesBalanced
198 noSelfMoves <> movesBalanced
80 where
199 where
81 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
200 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
201+ selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
82− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
202+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
203+ selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
83− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
204+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
84 selfMove _ = Nothing
205 selfMove _ = Nothing
85 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
206 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
86− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
207+ unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
87 case DMap.lookup src m of
208 case DMap.lookup src m of
88 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
209 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
89− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
210+ Just (NodeInfo _ (To_Move (dst' :=> _))) ->
90 if isNothing (dst' `geq` dst)
211 if isNothing (dst' `geq` dst)
91 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
212 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
92 else Nothing
213 else Nothing
93 _ ->
214 _ ->
94 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
215 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
95− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
216+ unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
96 case DMap.lookup dst m of
217 case DMap.lookup dst m of
97 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
218 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
98− Just (NodeInfo (From_Move src') _) ->
219+ Just (NodeInfo (From_Move (src' :=> _)) _) ->
99 if isNothing (src' `geq` src)
220 if isNothing (src' `geq` src)
100 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
221 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
101 else Nothing
222 else Nothing
@@ -104,35 +225,49 @@ validationErrorsForPatchDMapWithMove m =
104 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
225 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
105 unbalancedMove _ = Nothing
226 unbalancedMove _ = Nothing
106
227
107−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
108−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
109− PatchDMapWithMove a == PatchDMapWithMove b = a == b
110−
111-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
228-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
112data Pair1 f g a = Pair1 (f a) (g a)
229data Pair1 f g a = Pair1 (f a) (g a)
113
230
114-- |Helper data structure used for composing patches using the monoid instance.
231-- |Helper data structure used for composing patches using the monoid instance.
115−data Fixup k v a
232+data Fixup k p a
116 = Fixup_Delete
233 = Fixup_Delete
117− | Fixup_Update (These (From k v a) (To k a))
234+ | Fixup_Update (These (From k p a) (To k p a))
118−
235+
119−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
236+-- | Compose patches having the same effect as applying the patches in turn:
237+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
238+instance ( GCompare k
239+ , Cat.Semigroupoid p
240+ -- , Cat.DecidablyEmpty p
241+ , PatchHet2 p
242+ , PatchSource1 p ~ PatchTarget1 p
120−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
243+ ) => Semigroup (PatchDMapWithMove k p) where
121 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
244 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
122 where
245 where
246+ connections :: [DSum k (Pair1 (To k p) (From k p))]
247+ connections = DMap.toList $ DMap.intersectionWithKey
123− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
248+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
249+ ma
250+ mb
124− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
251+ h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
125− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
252+ h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
126− (Just toAfter, From_Move fromBefore)
253+ (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
127− | isJust $ fromBefore `geq` toAfter
254+ --case toAfter `geq` fromBefore of
255+ -- Just Refl | Just Refl <- Cat.isId p0 ->
128− -> [toAfter :=> Fixup_Delete]
256+ -- [ toAfter :=> Fixup_Delete ]
129− | otherwise
257+ -- _ ->
130− -> [ toAfter :=> Fixup_Update (This editBefore)
258+ [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
131− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
259+ , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
132− ]
260+ ]
261+ (To_NonMove, From_Move (fromBefore :=> _)) ->
133− (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
262+ -- The item is destroyed in the second patch, so indicate that it is
263+ -- destroyed in the source map
264+ [fromBefore :=> Fixup_Update (That To_NonMove)]
265+ (To_Move (toAfter :=> p), From_Insert val) ->
266+ [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
267+ (To_Move (toAfter :=> _), From_Delete) ->
134− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
268+ [toAfter :=> Fixup_Update (This From_Delete)]
135− (Nothing, _) -> []
269+ (To_NonMove, _) ->
270+ []
136 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
271 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
137 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
272 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
138 | This x <- a, That y <- b
273 | This x <- a, That y <- b
@@ -163,13 +298,19 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
163 These _ b -> Just b
298 These _ b -> Just b
164 That b -> Just b
299 That b -> Just b
165
300
166−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
301+-- | Compose patches having the same effect as applying the patches in turn:
302+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
303+instance ( GCompare k
304+ , Cat.Semigroupoid p
305+ -- , DecidablyEmpty p
306+ , PatchHet2 p
307+ , PatchSource1 p ~ PatchTarget1 p
167−instance GCompare k => Monoid (PatchDMapWithMove k v) where
308+ ) => Monoid (PatchDMapWithMove k p) where
168 mempty = PatchDMapWithMove mempty
309 mempty = PatchDMapWithMove mempty
169 mappend = (<>)
310 mappend = (<>)
170
311
171{-
312{-
172−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
313+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
173PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
314PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
174 where
315 where
175 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
316 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
@@ -190,25 +331,31 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
190 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
331 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
191-}
332-}
192
333
193−-- |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'.
334+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
335+-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
336+-- 'DMap.insert'.
194−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
337+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
195insertDMapKey k v =
338insertDMapKey k v =
196− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
339+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
197
340
198−-- |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:
341+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value
342+-- from the first key @k a@ to the second key @k a@, equivalent to:
199--
343--
200-- @
344-- @
201-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
345-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
202-- @
346-- @
347+moveDMapKey
348+ :: GCompare k
203−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
349+ => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
204moveDMapKey src dst = case src `geq` dst of
350moveDMapKey src dst = case src `geq` dst of
205 Nothing -> PatchDMapWithMove $ DMap.fromList
351 Nothing -> PatchDMapWithMove $ DMap.fromList
206− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
352+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
207− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
353+ , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
208 ]
354 ]
209− Just _ -> mempty
355+ Just _ -> PatchDMapWithMove DMap.empty
210
356
211−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
357+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
358+-- in the mapping, equivalent to:
212--
359--
213-- @
360-- @
214-- let aMay = DMap.lookup a dmap
361-- let aMay = DMap.lookup a dmap
@@ -217,17 +364,18 @@ moveDMapKey src dst = case src `geq` dst of
217-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
364-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
218-- . DMap.delete a . DMap.delete b $ dmap
365-- . DMap.delete a . DMap.delete b $ dmap
219-- @
366-- @
220−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
367+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
221swapDMapKey src dst = case src `geq` dst of
368swapDMapKey src dst = case src `geq` dst of
222 Nothing -> PatchDMapWithMove $ DMap.fromList
369 Nothing -> PatchDMapWithMove $ DMap.fromList
223− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
370+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
224− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
371+ , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
225 ]
372 ]
226− Just _ -> mempty
373+ Just _ -> PatchDMapWithMove DMap.empty
227
374
228−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
375+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
376+-- the mapping, equivalent to 'DMap.delete'.
229deleteDMapKey :: k a -> PatchDMapWithMove k v
377deleteDMapKey :: k a -> PatchDMapWithMove k v
230−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
378+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
231
379
232{-
380{-
233k1, k2 :: Const2 Int () ()
381k1, k2 :: Const2 Int () ()
@@ -253,17 +401,20 @@ dst (PatchDMapWithMove x _) = x
253src (PatchDMapWithMove _ x) = x
401src (PatchDMapWithMove _ x) = x
254-}
402-}
255
403
256−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
404+-- | Extract the 'DMap' representing the patch changes from the
405+-- 'PatchDMapWithMove'.
257unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
406unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
258unPatchDMapWithMove (PatchDMapWithMove p) = p
407unPatchDMapWithMove (PatchDMapWithMove p) = p
259
408
260−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
409+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
410+-- without checking any invariants.
261--
411--
262-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
412-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
263unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
413unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
264unsafePatchDMapWithMove = PatchDMapWithMove
414unsafePatchDMapWithMove = PatchDMapWithMove
265
415
416+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while
266−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
417+-- checking invariants. If the invariants are satisfied, @Right p@ is returned
267-- otherwise @Left errors@.
418-- otherwise @Left errors@.
268patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
419patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
269patchDMapWithMove dm =
420patchDMapWithMove dm =
@@ -271,94 +422,196 @@ patchDMapWithMove dm =
271 [] -> Right $ unsafePatchDMapWithMove dm
422 [] -> Right $ unsafePatchDMapWithMove dm
272 errs -> Left errs
423 errs -> Left errs
273
424
274−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
425+-- | Map a natural transform @v -> v'@ over the given patch, transforming
426+-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
275−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
427+mapPatchDMapWithMove
428+ :: forall k p p'
429+ . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
430+ -> (forall from to. p from to -> p' from to)
431+ -> PatchDMapWithMove k p
432+ -> PatchDMapWithMove k p'
276−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
433+mapPatchDMapWithMove f g (PatchDMapWithMove m) =
434+ PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
277− DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
435+ { _nodeInfo_from = h $ _nodeInfo_from ni
436+ , _nodeInfo_to = j $ _nodeInfo_to ni
437+ }) m
278− where g :: forall a. From k v a -> From k v' a
438+ where h :: forall a. From k p a -> From k p' a
279− g = \case
439+ h = \case
280 From_Insert v -> From_Insert $ f v
440 From_Insert v -> From_Insert $ f v
281 From_Delete -> From_Delete
441 From_Delete -> From_Delete
282− From_Move k -> From_Move k
442+ From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
283−
443+ j :: forall a. To k p a -> To k p' a
444+ j = \case
445+ To_NonMove -> To_NonMove
446+ To_Move (k :=> p) -> To_Move $ k :=> g p
447+
448+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
284−-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
449+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
450+-- ('PatchDMapWithMove' k v')@.
285−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
451+traversePatchDMapWithMove
452+ :: forall m k p p'
453+ . Applicative m
454+ => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
455+ -> (forall from to. p from to -> m (p' from to))
456+ -> PatchDMapWithMove k p
457+ -> m (PatchDMapWithMove k p')
286−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
458+traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
287−
459+ (\_ -> f)
460+ (\_ _ -> g)
461+
462+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
288−-- |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')@.
463+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
464+-- ('PatchDMapWithMove' k v')@.
289−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
465+traversePatchDMapWithMoveWithKey
466+ :: forall m k p p'
467+ . Applicative m
468+ => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
469+ -> (forall from to. k from -> k to -> p from to -> m (p' from to))
470+ -> PatchDMapWithMove k p
471+ -> m (PatchDMapWithMove k p')
290−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
472+traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
473+ PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
474+ <$> h k (_nodeInfo_from ni)
475+ <*> j k (_nodeInfo_to ni)) m
291− where g :: forall a. k a -> From k v a -> m (From k v' a)
476+ where h :: forall a. k a -> From k p a -> m (From k p' a)
292− g k = \case
477+ h k = \case
293 From_Insert v -> From_Insert <$> f k v
478 From_Insert v -> From_Insert <$> f k v
294 From_Delete -> pure From_Delete
479 From_Delete -> pure From_Delete
295− From_Move fromKey -> pure $ From_Move fromKey
480+ From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
296−
481+ j :: forall a. k a -> To k p a -> m (To k p' a)
482+ j k = \case
483+ To_NonMove -> pure To_NonMove
484+ To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
485+
297−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
486+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
487+-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
298−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
488+nodeInfoMapFrom
489+ :: (From k p a -> From k p' a)
490+ -> (To k p a -> To k p' a)
491+ -> NodeInfo k p a
492+ -> NodeInfo k p' a
493+nodeInfoMapFrom f g ni = NodeInfo
299−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
494+ { _nodeInfo_from = f $ _nodeInfo_from ni
300−
495+ , _nodeInfo_to = g $ _nodeInfo_to ni
496+ }
497+
301−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
498+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
499+-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
500+nodeInfoMapFromM
501+ :: Applicative f
502+ => (From k p a -> f (From k p' a))
503+ -> (To k p a -> f (To k p' a))
504+ -> NodeInfo k p a
505+ -> f (NodeInfo k p' a)
506+nodeInfoMapFromM f g ni = NodeInfo
303−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
507+ <$> f (_nodeInfo_from ni)
304−
508+ <*> g (_nodeInfo_to ni)
509+
305−-- |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
510+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
511+-- from @k a@ to @'Some' k@ and applying a given weakening function
306−-- values.
512+-- @PatchTarget1 p a -> v'@ to values.
307−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) (Proxy v')
513+weakenPatchDMapWithMoveWith
514+ :: forall k p p'
515+ . (forall a. PatchTarget1 p a -> PatchTarget p')
516+ -> (forall from to. p from to -> p')
517+ -> PatchDMapWithMove k p
518+ -> PatchMapWithMove (Some k) p'
308−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
519+weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
520+ PatchMapWithMove $ weakenDMapWith h m
309− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) (Proxy v')
521+ where h :: forall a. NodeInfo k p a -> MapWithMove.NodeInfo (Some k) p'
310− g ni = MapWithMove.NodeInfo
522+ h ni = MapWithMove.NodeInfo
311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
523 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
312 From_Insert v -> MapWithMove.From_Insert $ f v
524 From_Insert v -> MapWithMove.From_Insert $ f v
313 From_Delete -> MapWithMove.From_Delete
525 From_Delete -> MapWithMove.From_Delete
314− From_Move k -> MapWithMove.From_Move (Some k) Proxy
526+ From_Move (k :=> Flip p) -> MapWithMove.From_Move (Some k) $ g p
315− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
527+ , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
528+ To_NonMove -> MapWithMove.To_NonMove
529+ To_Move (k :=> p) -> MapWithMove.To_Move (Some k) $ g p
316 }
530 }
317
531
532+-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
318−-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
533+-- v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
319−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
534+-- dependency in the typing and all points are already @a@, hence the function
535+-- to map each value to @v'@ is not higher rank.
320−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k (Proxy v')
536+patchDMapWithMoveToPatchMapWithMoveWith
537+ :: forall k p p' a
538+ . (PatchTarget1 p a -> PatchTarget p')
539+ -> (p a a -> p')
540+ -> PatchDMapWithMove (Const2 k a) p
541+ -> PatchMapWithMove k p'
321−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
542+patchDMapWithMoveToPatchMapWithMoveWith f g (PatchDMapWithMove m) =
543+ PatchMapWithMove $ dmapToMapWith h m
322− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k (Proxy v')
544+ where h :: NodeInfo (Const2 k a) p a -> MapWithMove.NodeInfo k p'
323− g ni = MapWithMove.NodeInfo
545+ h ni = MapWithMove.NodeInfo
324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
546 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
325 From_Insert v -> MapWithMove.From_Insert $ f v
547 From_Insert v -> MapWithMove.From_Insert $ f v
326 From_Delete -> MapWithMove.From_Delete
548 From_Delete -> MapWithMove.From_Delete
327− From_Move (Const2 k) -> MapWithMove.From_Move k Proxy
549+ From_Move (Const2 k :=> Flip p) -> MapWithMove.From_Move k $ g p
328− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
550+ , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
551+ To_NonMove -> MapWithMove.To_NonMove
552+ To_Move (Const2 k :=> p) -> MapWithMove.To_Move k $ g p
329 }
553 }
330
554
331−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
555+-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
556+-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a
332−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
557+-- dependently typed one but which always has a constant key type represented by
558+-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
333−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
559+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
334−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'
560+const2PatchDMapWithMoveWith
561+ :: forall k v v' a
562+ . (v -> v' a)
563+ -> PatchMapWithMove k (Proxy v)
564+ -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
565+const2PatchDMapWithMoveWith f (PatchMapWithMove p) =
335−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
566+ PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
336− where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
567+ where g :: (k, MapWithMove.NodeInfo k (Proxy v))
568+ -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
337 g (k, ni) = Const2 k :=> NodeInfo
569 g (k, ni) = Const2 k :=> NodeInfo
338 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
570 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
339 MapWithMove.From_Insert v -> From_Insert $ f v
571 MapWithMove.From_Insert v -> From_Insert $ f v
340 MapWithMove.From_Delete -> From_Delete
572 MapWithMove.From_Delete -> From_Delete
341− MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey
573+ MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
342− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
574+ , _nodeInfo_to = case MapWithMove._nodeInfo_to ni of
575+ MapWithMove.To_NonMove -> To_NonMove
576+ MapWithMove.To_Move toKey Proxy -> To_Move $ Const2 toKey :=> Proxy3
343 }
577 }
344
578
345-- | Apply the insertions, deletions, and moves to a given 'DMap'.
579-- | Apply the insertions, deletions, and moves to a given 'DMap'.
580+instance ( GCompare k
581+ , PatchHet2 p
582+ , PatchSource1 p ~ PatchTarget1 p
346−instance GCompare k => Patch (PatchDMapWithMove k v) where
583+ ) => PatchHet (PatchDMapWithMove k p) where
584+ type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
347− type PatchTarget (PatchDMapWithMove k v) = DMap k v
585+ type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
586+
587+instance ( GCompare k
588+ , PatchHet2 p
589+ , PatchSource1 p ~ PatchTarget1 p
590+ ) => Patch (PatchDMapWithMove k p) where
348− 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?
591+ apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
592+ -- TODO: return Nothing sometimes --Note: the strict application here is
593+ -- critical to ensuring that incremental merges don't hold onto all their
594+ -- prerequisite events forever; can we make this more robust?
349− where insertions = DMap.mapMaybeWithKey insertFunc p
595+ where insertions = DMap.mapMaybeWithKey insertFunc m
350− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
596+ insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
351 insertFunc _ ni = case _nodeInfo_from ni of
597 insertFunc _ ni = case _nodeInfo_from ni of
352 From_Insert v -> Just v
598 From_Insert v -> Just v
353− From_Move k -> DMap.lookup k old
599+ From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
354 From_Delete -> Nothing
600 From_Delete -> Nothing
355− deletions = DMap.mapMaybeWithKey deleteFunc p
601+ deletions = DMap.mapMaybeWithKey deleteFunc m
356− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
602+ deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
357 deleteFunc _ ni = case _nodeInfo_from ni of
603 deleteFunc _ ni = case _nodeInfo_from ni of
358 From_Delete -> Just $ Constant ()
604 From_Delete -> Just $ Constant ()
359 _ -> Nothing
605 _ -> Nothing
360
606
361−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
607+-- | Get the values that will be replaced, deleted, or moved if the given patch
608+-- is applied to the given 'DMap'.
362−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
609+getDeletionsAndMoves
610+ :: ( GCompare k
611+ , PatchSource1 p ~ PatchTarget1 p
612+ )
613+ => PatchDMapWithMove k p
614+ -> DMap k (PatchSource1 p)
615+ -> DMap k (Product (PatchTarget1 p) (To k p))
363getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
616getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
364 where f _ v ni = Pair v $ _nodeInfo_to ni
617 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
@@ -19,8 +19,10 @@ import Data.Patch.Class
19newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
19newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
20
20
21-- | Apply the insertions or deletions to a given 'IntMap'.
21-- | Apply the insertions or deletions to a given 'IntMap'.
22−instance Patch (PatchIntMap a) where
22+instance PatchHet (PatchIntMap a) where
23+ type PatchSource (PatchIntMap a) = IntMap a
23 type PatchTarget (PatchIntMap a) = IntMap a
24 type PatchTarget (PatchIntMap a) = IntMap a
25+instance Patch (PatchIntMap a) where
24 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
26 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
25 let removes = IntMap.filter isNothing p
27 let removes = IntMap.filter isNothing p
26 adds = IntMap.mapMaybe id p
28 adds = IntMap.mapMaybe id p
src/Data/Patch/Map.hs+3−1
@@ -18,8 +18,10 @@ newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
18 deriving (Show, Read, Eq, Ord)
18 deriving (Show, Read, Eq, Ord)
19
19
20-- | Apply the insertions or deletions to a given 'Map'.
20-- | Apply the insertions or deletions to a given 'Map'.
21−instance Ord k => Patch (PatchMap k v) where
21+instance Ord k => PatchHet (PatchMap k v) where
22+ type PatchSource (PatchMap k v) = Map k v
22 type PatchTarget (PatchMap k v) = Map k v
23 type PatchTarget (PatchMap k v) = Map k v
24+instance Ord k => Patch (PatchMap k v) where
23 {-# INLINABLE apply #-}
25 {-# INLINABLE apply #-}
24 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?
26 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?
25 where insertions = Map.mapMaybeWithKey (const id) p
27 where insertions = Map.mapMaybeWithKey (const id) p
src/Data/Patch/MapWithMove.hs+70−44
@@ -41,7 +41,7 @@ deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k
41data NodeInfo k p = NodeInfo
41data NodeInfo k p = NodeInfo
42 { _nodeInfo_from :: !(From k p)
42 { _nodeInfo_from :: !(From k p)
43 -- ^ Where do we get the new value for this key?
43 -- ^ Where do we get the new value for this key?
44− , _nodeInfo_to :: !(To k)
44+ , _nodeInfo_to :: !(To k p)
45 -- ^ If the old value is being kept (i.e. moved rather than deleted or
45 -- ^ If the old value is being kept (i.e. moved rather than deleted or
46 -- replaced), where is it going?
46 -- replaced), where is it going?
47 }
47 }
@@ -64,14 +64,23 @@ deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
64-- | Describe where a key's old value will go. If this is 'Just', that means
64-- | Describe where a key's old value will go. If this is 'Just', that means
65-- the key's old value will be moved to the given other key; if it is 'Nothing',
65-- the key's old value will be moved to the given other key; if it is 'Nothing',
66-- that means it will be deleted.
66-- that means it will be deleted.
67−type To = Maybe
67+data To k p
68+ = To_NonMove
69+ | To_Move !k !p
70+
71+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (To k p)
72+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (To k p)
73+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (To k p)
74+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (To k p)
68
75
69-- | Create a 'PatchMapWithMove', validating it
76-- | Create a 'PatchMapWithMove', validating it
70patchMapWithMove
77patchMapWithMove
71 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
78 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
72patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
79patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
73 where valid = forwardLinks == backwardLinks
80 where valid = forwardLinks == backwardLinks
74− forwardLinks = Map.mapMaybe _nodeInfo_to m
81+ forwardLinks = flip Map.mapMaybe m $ \x -> case _nodeInfo_to x of
82+ To_NonMove -> Nothing
83+ To_Move to _ -> Just to
75 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
84 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
76 case _nodeInfo_from p of
85 case _nodeInfo_from p of
77 From_Move from _ -> Just (from, to)
86 From_Move from _ -> Just (from, to)
@@ -82,7 +91,7 @@ patchMapWithMoveInsertAll
82 :: Map k (PatchTarget p) -> PatchMapWithMove k p
91 :: Map k (PatchTarget p) -> PatchMapWithMove k p
83patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
92patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
84 { _nodeInfo_from = From_Insert v
93 { _nodeInfo_from = From_Insert v
85− , _nodeInfo_to = Nothing
94+ , _nodeInfo_to = To_NonMove
86 }
95 }
87
96
88-- | Extract the internal representation of the 'PatchMapWithMove'
97-- | Extract the internal representation of the 'PatchMapWithMove'
@@ -93,7 +102,7 @@ unPatchMapWithMove (PatchMapWithMove p) = p
93-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
102-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
94insertMapKey
103insertMapKey
95 :: k -> PatchTarget p -> PatchMapWithMove k p
104 :: k -> PatchTarget p -> PatchMapWithMove k p
96−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
105+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) To_NonMove
97
106
98-- |Make a @'PatchMapWithMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
107-- |Make a @'PatchMapWithMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
99--
108--
@@ -106,8 +115,8 @@ moveMapKey src dst
106 | src == dst = mempty
115 | src == dst = mempty
107 | otherwise =
116 | otherwise =
108 PatchMapWithMove $ Map.fromList
117 PatchMapWithMove $ Map.fromList
109− [ (dst, NodeInfo (From_Move src mempty) Nothing)
118+ [ (dst, NodeInfo (From_Move src mempty) To_NonMove)
110− , (src, NodeInfo From_Delete (Just dst))
119+ , (src, NodeInfo From_Delete (To_Move dst mempty))
111 ]
120 ]
112
121
113-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
122-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
@@ -120,19 +129,21 @@ moveMapKey src dst
120-- . Map.delete a . Map.delete b $ map
129-- . Map.delete a . Map.delete b $ map
121-- @
130-- @
122swapMapKey
131swapMapKey
132+ :: (DecidablyEmpty p, Patch p)
123− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
133+ => Ord k => k -> k -> PatchMapWithMove k p
124swapMapKey src dst
134swapMapKey src dst
125 | src == dst = mempty
135 | src == dst = mempty
126 | otherwise =
136 | otherwise =
127 PatchMapWithMove $ Map.fromList
137 PatchMapWithMove $ Map.fromList
128− [ (dst, NodeInfo (From_Move src mempty) (Just src))
138+ [ (dst, NodeInfo (From_Move src mempty) (To_Move dst mempty))
129− , (src, NodeInfo (From_Move dst mempty) (Just dst))
139+ , (src, NodeInfo (From_Move dst mempty) (To_Move dst mempty))
130 ]
140 ]
131
141
132−-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
142+-- | Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in
143+-- the mapping, equivalent to 'Map.delete'.
133deleteMapKey
144deleteMapKey
134 :: k -> PatchMapWithMove k v
145 :: k -> PatchMapWithMove k v
135−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
146+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete To_NonMove
136
147
137-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
148-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
138--
149--
@@ -142,9 +153,16 @@ unsafePatchMapWithMove
142unsafePatchMapWithMove = PatchMapWithMove
153unsafePatchMapWithMove = PatchMapWithMove
143
154
144-- | Apply the insertions, deletions, and moves to a given 'Map'
155-- | Apply the insertions, deletions, and moves to a given 'Map'
145−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
156+instance (Ord k, Patch p) => PatchHet (PatchMapWithMove k p) where
157+ type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)
146 type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
158 type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
159+
160+instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
161+ -- TODO: return Nothing sometimes
147− apply (PatchMapWithMove m) 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?
162+ -- Note: the strict application here is critical to ensuring that incremental
163+ -- merges don't hold onto all their prerequisite events forever; can we make
164+ -- this more robust?
165+ apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
148 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
166 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
149 From_Insert v -> Just v
167 From_Insert v -> Just v
150 From_Move k p -> applyAlways p <$> Map.lookup k old
168 From_Move k p -> applyAlways p <$> Map.lookup k old
@@ -182,7 +200,7 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW
182 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
200 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
183 g (to, _) (from, _) = if to == from then Nothing else
201 g (to, _) (from, _) = if to == from then Nothing else
184 let Just movingTo = Map.lookup from reverseMapping
202 let Just movingTo = Map.lookup from reverseMapping
185− in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
203+ in Just (to, NodeInfo (From_Move from mempty) $ To_Move movingTo mempty)
186
204
187-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
205-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
188-- will produce a 'Map' with the same values as the second 'Map' but with the
206-- will produce a 'Map' with the same values as the second 'Map' but with the
@@ -209,25 +227,32 @@ patchThatChangesMap oldByIndex newByIndex = patch
209 then Map.delete v remainingValues
227 then Map.delete v remainingValues
210 else Map.insert v remainingKeys remainingValues
228 else Map.insert v remainingKeys remainingValues
211 case Map.lookup v remainingValues of
229 case Map.lookup v remainingValues of
212− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
230+ Nothing -> return $ NodeInfo (From_Insert v) $ To_Move undefined undefined -- There's no existing value we can take
213 Just fromKs ->
231 Just fromKs ->
214 if k `Set.member` fromKs
232 if k `Set.member` fromKs
215 then do
233 then do
216 putRemainingKeys $ Set.delete k fromKs
234 putRemainingKeys $ Set.delete k fromKs
217− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
235+ return $ NodeInfo (From_Move k mempty) $ To_Move undefined undefined -- There's an existing value, and it's here, so no patch necessary
218 else do
236 else do
219 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
237 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
220 putRemainingKeys remainingKeys
238 putRemainingKeys remainingKeys
221− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
239+ return $ NodeInfo (From_Move fromK mempty) $ To_Move undefined undefined
222 Map.traverseWithKey f newByIndex
240 Map.traverseWithKey f newByIndex
223 unusedOldKeys = fold unusedValuesByValue
241 unusedOldKeys = fold unusedValuesByValue
224 pointlessMove k = \case
242 pointlessMove k = \case
225 From_Move k' _ | k == k' -> True
243 From_Move k' _ | k == k' -> True
226 _ -> False
244 _ -> False
227 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
245 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
228− then Just undefined
246+ then To_Move undefined undefined
229− else Nothing
247+ else To_NonMove
230− patch = unsafePatchMapWithMove $ 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
248+ patch = unsafePatchMapWithMove $ Map.filterWithKey
249+ (\k -> not . pointlessMove k . _nodeInfo_from)
250+ $ Map.mergeWithKey
251+ (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a)
252+ (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k)
253+ (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k)
254+ insertsAndMoves
255+ oldByIndex
231
256
232-- | Change the 'From' value of a 'NodeInfo'
257-- | Change the 'From' value of a 'NodeInfo'
233nodeInfoMapFrom
258nodeInfoMapFrom
@@ -242,35 +267,41 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _
242
267
243-- | Set the 'To' field of a 'NodeInfo'
268-- | Set the 'To' field of a 'NodeInfo'
244nodeInfoSetTo
269nodeInfoSetTo
245− :: To k -> NodeInfo k v -> NodeInfo k v
270+ :: To k p -> NodeInfo k p -> NodeInfo k p
246nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
271nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
247
272
248−-- |Helper data structure used for composing patches using the monoid instance.
273+-- | Helper data structure used for composing patches using the monoid instance.
249−data Fixup k v
274+data Fixup k p
250 = Fixup_Delete
275 = Fixup_Delete
251− | Fixup_Update (These (From k v) (To k))
276+ | Fixup_Update (These (From k p) (To k p))
252
277
253−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
278+-- | Compose patches having the same effect as applying the patches in turn:
279+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
254instance ( Ord k
280instance ( Ord k
255− , Monoid p
256 , DecidablyEmpty p
281 , DecidablyEmpty p
257 , Patch p
282 , Patch p
258 ) => Semigroup (PatchMapWithMove k p) where
283 ) => Semigroup (PatchMapWithMove k p) where
259 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
284 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
260 where
285 where
261 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
286 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
262− h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
287+ h :: (k, (To k p, From k p)) -> [(k, Fixup k p)]
263− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
288+ h (_, (editAfter, editBefore)) = case (editAfter, editBefore) of
264− (Just toAfter, From_Move fromBefore p)
289+ (To_Move toAfter p1, From_Move fromBefore p0)
265− | fromBefore == toAfter && isNull p
290+ | fromBefore == toAfter && isNull p0
266 -> [(toAfter, Fixup_Delete)]
291 -> [(toAfter, Fixup_Delete)]
267 | otherwise
292 | otherwise
268− -> [ (toAfter, Fixup_Update (This editBefore))
293+ -> [ (toAfter, Fixup_Update (This $ From_Move fromBefore $ p1 <> p0))
269− , (fromBefore, Fixup_Update (That mToAfter))
294+ , (fromBefore, Fixup_Update (That $ To_Move toAfter $ p1 <> p0))
270 ]
295 ]
296+ (To_NonMove, From_Move fromBefore _) ->
271− (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
297+ -- The item is destroyed in the second patch, so indicate that it is
298+ -- destroyed in the source map
299+ [(fromBefore, Fixup_Update (That editAfter))]
300+ (To_Move toAfter p, From_Insert val) ->
272− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
301+ [(toAfter, Fixup_Update $ This $ From_Insert $ applyAlways p val)]
273− (Nothing, _) -> []
302+ (To_Move toAfter _, From_Delete) ->
303+ [(toAfter, Fixup_Update $ This From_Delete)]
304+ (To_NonMove, _) -> []
274 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
305 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
275 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
306 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
276 | This x <- a, That y <- b
307 | This x <- a, That y <- b
@@ -286,13 +317,7 @@ instance ( Ord k
286 applyFixup _ ni = \case
317 applyFixup _ ni = \case
287 Fixup_Delete -> Nothing
318 Fixup_Delete -> Nothing
288 Fixup_Update u -> Just $ NodeInfo
319 Fixup_Update u -> Just $ NodeInfo
289− { _nodeInfo_from = case _nodeInfo_from ni of
320+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
290− f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
291− Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
292− Just (From_Insert v) -> From_Insert $ applyAlways p' v
293− Just From_Delete -> From_Delete
294− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
295− _ -> error "PatchMapWithMove: fixup for non-move From"
296 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
321 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
297 }
322 }
298 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
323 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
@@ -308,7 +333,8 @@ instance ( Ord k
308 That b -> Just b
333 That b -> Just b
309
334
310--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
335--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
311−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
336+-- | Compose patches having the same effect as applying the patches in turn:
337+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
312instance ( Ord k
338instance ( Ord k
313 , Monoid p
339 , Monoid p
314 , DecidablyEmpty p
340 , DecidablyEmpty p