git.iko.soy/patch
on develop help sign in
Add notion of heterogenous patch
7fd18c0John Ericson
src/Data/Patch.hs+3−1
compare with develop
unifiedsplit
@@ -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
src/Data/Patch/Class.hs+41−5
@@ -1,4 +1,6 @@
1+{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE TypeOperators #-}
2-- | The interface for types which represent changes made to other types
4-- | The interface for types which represent changes made to other types
3module Data.Patch.Class where
5module Data.Patch.Class where
4
6
@@ -6,13 +8,39 @@ import Data.Functor.Identity
6import Data.Maybe
8import Data.Maybe
7import Data.Semigroup (Semigroup(..))
9import Data.Semigroup (Semigroup(..))
8import Data.Proxy
10import Data.Proxy
11+import Data.Type.Equality ((:~:) (..))
12+
13+class PatchHet p where
14+ type PatchSource p :: *
15+ type PatchTarget p :: *
16+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
17+ -- 'Nothing'.
18+ applyHet
19+ :: p
20+ -> PatchSource p
21+ -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
22+ default applyHet
23+ :: Patch p
24+ => p
25+ -> PatchSource p
26+ -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
27+ applyHet p a = case apply p a of
28+ Nothing -> Left Refl
29+ Just a' -> Right a'
30+
31+-- | Apply a 'PatchHet'; if it does nothing, return the original value
32+applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
33+applyAlwaysHet p t = case applyHet p t of
34+ Left Refl -> t
35+ Right t' -> t'
9
36
10-- | A 'Patch' type represents a kind of change made to a datastructure.
37-- | A 'Patch' type represents a kind of change made to a datastructure.
11--
38--
12-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
39-- 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@.
40-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
41+class ( PatchHet p
42+ , PatchSource p ~ PatchTarget p
14−class Patch p where
43+ ) => Patch p where
15− type PatchTarget p :: *
16 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
44 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
17 -- 'Nothing'.
45 -- 'Nothing'.
18 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
46 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -22,19 +50,27 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
22applyAlways p t = fromMaybe t $ apply p t
50applyAlways p t = fromMaybe t $ apply p t
23
51
24-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
52-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
25−instance Patch (Identity a) where
53+instance PatchHet (Identity a) where
54+ type PatchSource (Identity a) = a
26 type PatchTarget (Identity a) = a
55 type PatchTarget (Identity a) = a
56+instance Patch (Identity a) where
27 apply (Identity a) _ = Just a
57 apply (Identity a) _ = Just a
28
58
29-- | '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
30−instance Patch (Proxy a) where
60+instance PatchHet (Proxy a) where
61+ type PatchSource (Proxy a) = a
31 type PatchTarget (Proxy a) = a
62 type PatchTarget (Proxy a) = a
63+instance Patch (Proxy a) where
32 apply ~Proxy _ = Nothing
64 apply ~Proxy _ = Nothing
33
65
34-- | Like '(.)', but composes functions that return patches rather than
66-- | Like '(.)', but composes functions that return patches rather than
35-- functions that return new values. The Semigroup instance for patches must
67-- functions that return new values. The Semigroup instance for patches must
36-- apply patches right-to-left, like '(.)'.
68-- apply patches right-to-left, like '(.)'.
37−composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
69+composePatchFunctions
70+ :: (Patch p, Semigroup p)
71+ => (PatchTarget p -> p)
72+ -> (PatchTarget p -> p)
73+ -> PatchTarget p -> p
38composePatchFunctions g f a =
74composePatchFunctions g f a =
39 let fp = f a
75 let fp = f a
40 in g (applyAlways fp a) <> fp
76 in g (applyAlways fp a) <> fp
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+3−1
@@ -343,8 +343,10 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
343 }
343 }
344
344
345-- | Apply the insertions, deletions, and moves to a given 'DMap'.
345-- | Apply the insertions, deletions, and moves to a given 'DMap'.
346−instance GCompare k => Patch (PatchDMapWithMove k v) where
346+instance GCompare k => PatchHet (PatchDMapWithMove k v) where
347+ type PatchSource (PatchDMapWithMove k v) = DMap k v
347 type PatchTarget (PatchDMapWithMove k v) = DMap k v
348 type PatchTarget (PatchDMapWithMove k v) = DMap k v
349+instance GCompare k => Patch (PatchDMapWithMove k v) 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?
350 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?
349 where insertions = DMap.mapMaybeWithKey insertFunc p
351 where insertions = DMap.mapMaybeWithKey insertFunc p
350 insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
352 insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
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+8−2
@@ -142,9 +142,15 @@ unsafePatchMapWithMove
142unsafePatchMapWithMove = PatchMapWithMove
142unsafePatchMapWithMove = PatchMapWithMove
143
143
144-- | Apply the insertions, deletions, and moves to a given 'Map'
144-- | Apply the insertions, deletions, and moves to a given 'Map'
145−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
145+instance (Ord k, Patch p) => PatchHet (PatchMapWithMove k p) where
146+ type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)
146 type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
147 type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
148+instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
149+ -- 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?
150+ -- Note: the strict application here is critical to ensuring that incremental
151+ -- merges don't hold onto all their prerequisite events forever; can we make
152+ -- this more robust?
153+ 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
154 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
149 From_Insert v -> Just v
155 From_Insert v -> Just v
150 From_Move k p -> applyAlways p <$> Map.lookup k old
156 From_Move k p -> applyAlways p <$> Map.lookup k old