7fd18c0 · patch · git.iko.soy

git.iko.soy/patch

Add notion of heterogenous patch

commit7fd18c03fa4187344394b284bb89537bc15815b5 authorJohn Ericson <git@JohnEricson.me> dateSat 11 Jan 2020, 01:58 (7 years ago) parentcf7b8fb

7 files changed+64−12

compare with develop

unifiedsplit

src/Data/Patch.hs+3−1 src/Data/Patch/Class.hs+41−5 src/Data/Patch/DMap.hs+3−1 src/Data/Patch/DMapWithMove.hs+3−1 src/Data/Patch/IntMap.hs+3−1 src/Data/Patch/Map.hs+3−1 src/Data/Patch/MapWithMove.hs+8−2

src/Data/Patch.hs+3−1

@@ -51,8 +51,10 @@ class Semigroup q => Additive q where

5151-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.

5252newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

5353

54−instance Additive p => Patch (AdditivePatch p) where

54+instance Additive p => PatchHet (AdditivePatch p) where

55+ type PatchSource (AdditivePatch p) = p

5556 type PatchTarget (AdditivePatch p) = p

57+instance Additive p => Patch (AdditivePatch p) where

5658 apply (AdditivePatch p) q = Just $ p <> q

5759

5860instance (Ord k, Group q) => Group (MonoidalMap k q) where

src/Data/Patch/Class.hs+41−5

@@ -1,4 +1,6 @@

1+{-# LANGUAGE DefaultSignatures #-}

12{-# LANGUAGE TypeFamilies #-}

3+{-# LANGUAGE TypeOperators #-}

24-- | The interface for types which represent changes made to other types

35module Data.Patch.Class where

@@ -6,13 +8,39 @@ import Data.Functor.Identity

68import Data.Maybe

79import Data.Semigroup (Semigroup(..))

810import 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'

936

1037-- | A 'Patch' type represents a kind of change made to a datastructure.

1138--

1239-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey

1340-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.

14−class Patch p where

15− type PatchTarget p :: *

41+class ( PatchHet p

42+ , PatchSource p ~ PatchTarget p

43+ ) => Patch p where

1644 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return

1745 -- 'Nothing'.

1846 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)

@@ -22,19 +50,27 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p

2250applyAlways p t = fromMaybe t $ apply p t

2351

2452-- | '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

2655 type PatchTarget (Identity a) = a

56+instance Patch (Identity a) where

2757 apply (Identity a) _ = Just a

2858

2959-- | '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

3162 type PatchTarget (Proxy a) = a

63+instance Patch (Proxy a) where

3264 apply ~Proxy _ = Nothing

3365

3466-- | Like '(.)', but composes functions that return patches rather than

3567-- functions that return new values. The Semigroup instance for patches must

3668-- 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

3874composePatchFunctions g f a =

3975 let fp = f a

4076 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)

3131deriving instance GCompare k => Monoid (PatchDMap k v)

3232

3333-- | 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

3536 type PatchTarget (PatchDMap k v) = DMap k v

37+instance GCompare k => Patch (PatchDMap k v) where

3638 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?

3739 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff

3840 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

343343 }

344344

345345-- | 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

347348 type PatchTarget (PatchDMapWithMove k v) = DMap k v

349+instance GCompare k => Patch (PatchDMapWithMove k v) where

348350 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?

349351 where insertions = DMap.mapMaybeWithKey insertFunc p

350352 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

1919newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

2020

2121-- | 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

2324 type PatchTarget (PatchIntMap a) = IntMap a

25+instance Patch (PatchIntMap a) where

2426 apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

2527 let removes = IntMap.filter isNothing p

2628 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) }

1818 deriving (Show, Read, Eq, Ord)

1919

2020-- | 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

2223 type PatchTarget (PatchMap k v) = Map k v

24+instance Ord k => Patch (PatchMap k v) where

2325 {-# INLINABLE apply #-}

2426 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?

2527 where insertions = Map.mapMaybeWithKey (const id) p

src/Data/Patch/MapWithMove.hs+8−2

@@ -142,9 +142,15 @@ unsafePatchMapWithMove

142142unsafePatchMapWithMove = PatchMapWithMove

143143

144144-- | 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)

146147 type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)

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?

148+instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where

149+ -- TODO: return Nothing sometimes

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)

148154 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of

149155 From_Insert v -> Just v

150156 From_Move k p -> applyAlways p <$> Map.lookup k old