develop...7fd18c0 · patch

ChangeLog.md+4

since splitsnapshots

unifiedsplit

@@ -4,6 +4,10 @@

4

5* `PatchMapWithMove` supports moves with a patch.

6

7+* Add `PatchDMapWithReset`

8+

9+* Add `Patchable`

10+

7## 0.0.1.0

11## 0.0.1.0

8

12

9* Support older GHCs with `split-these` flag.

13* Support older GHCs with `split-these` flag.

patch.cabal+2

@@ -44,9 +44,11 @@ library

44 , Data.Patch.Class

45 , Data.Patch.DMap

46 , Data.Patch.DMapWithMove

47+ , Data.Patch.DMapWithReset

47 , Data.Patch.IntMap

48 , Data.Patch.IntMap

48 , Data.Patch.Map

49 , Data.Patch.Map

49 , Data.Patch.MapWithMove

50 , Data.Patch.MapWithMove

51+ , Data.Patch.Patchable

50

52

51 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs

53 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs

52

54

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.

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

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

32

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 }

344

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/DMapWithReset.hsnew file+120

@@ -0,0 +1,120 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE Rank2Types #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

13+{-# OPTIONS_GHC -Wall #-}

14+

15+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

16+module Data.Patch.DMapWithReset where

17+

18+import Data.Patch.Class

19+

20+import Data.Dependent.Map (DMap, GCompare (..))

21+import qualified Data.Dependent.Map as DMap

22+import Data.Semigroup (Semigroup (..))

23+import Data.Constraint.Extras

24+

25+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.

26+-- Insertions are represented as @'ComposeMaybe' (Just value)@,

27+-- while deletions are represented as @'ComposeMaybe' Nothing@.

28+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }

29+

30+-- | Holds the information about each key: where its new value should come from,

31+-- and where its old value should go to

32+data By p a

33+ = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here

34+ | By_Delete -- ^ Delete the existing value, if any, from here

35+ | By_Patch (p a) -- ^ Patch the value here with the given patch

36+

37+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where

38+ x@(By_Insert _) <> _ = x

39+ By_Delete <> _ = By_Delete

40+ By_Patch x <> By_Insert y = By_Insert (applyAlways x y)

41+ By_Patch x <> By_Patch y = By_Patch (x <> y)

42+ By_Patch _ <> By_Delete = By_Delete

43+

44+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where

45+ mappend = (<>)

46+ mempty = By_Patch mempty

47+

48+instance

49+ ( GCompare k

50+ , Has' Semigroup k p

51+ , Has' Patch k p

52+ )

53+ => Semigroup (PatchDMapWithReset k p) where

54+ PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey

55+ (\k -> has' @Patch @p k

56+ $ has' @Semigroup @p k

57+ $ (<>)) xs ys

58+

59+instance

60+ ( GCompare k

61+ , Has' Semigroup k p

62+ , Has' Patch k p

63+ )

64+ => Monoid (PatchDMapWithReset k p) where

65+ mappend = (<>)

66+ mempty = PatchDMapWithReset DMap.empty

67+

68+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where

69+ type Patches1LocallyTarget p :: k -> *

70+

71+data These1 f g x

72+ = This1 (f x)

73+ | That1 (g x)

74+ | These1 (f x) (g x)

75+

76+mergeWithKey

77+ :: forall k v1 v2 v.

78+ (GCompare k)

79+ => (forall x. k x -> v1 x -> Maybe (v x))

80+ -> (forall x. k x -> v2 x -> Maybe (v x))

81+ -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))

82+ -> DMap k v1 -> DMap k v2 -> DMap k v

83+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)

84+ where

85+ doIt _ (This1 xs) (That1 ys) = These1 xs ys

86+ doIt _ _ _ = error "mergeWithKey misalligned keys"

87+

88+ onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)

89+ onlyThat k = \case

90+ This1 xs -> f k xs

91+ That1 ys -> g k ys

92+ These1 xs ys -> fg k xs ys

93+{-# INLINE mergeWithKey #-}

94+

95+-- | Apply the insertions or deletions to a given 'DMap'.

96+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where

97+

98+ type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)

99+

100+ apply = go

101+ where

102+ go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))

103+ go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff

104+ where

105+ updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)

106+ updates k ys = has @(Patches1Locally p) k $ \case

107+ By_Insert x -> Just x

108+ By_Delete -> Nothing

109+ By_Patch x -> Just $ applyAlways x ys

110+

111+ inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)

112+ inserts k = has @(Patches1Locally p) k $ \case

113+ By_Insert x -> Just x

114+ By_Delete -> Nothing

115+ By_Patch _ -> Nothing

116+

117+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)

118+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)

119+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)

120+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)

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)

20

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)

19

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

143

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

src/Data/Patch/Patchable.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeFamilies #-}

6+

7+-- The derived instances are undecidable in the case of a pathological instance like

8+-- instance Patch x where

9+-- type PatchTarget x = Patchable x

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+module Data.Patch.Patchable where

13+

14+-- import Data.Aeson

15+import GHC.Generics

16+

17+import Data.Patch

18+

19+-- | Like SemiMap/PartialMap but for anything patchable

20+data Patchable p

21+ = Patchable_Patch p

22+ | Patchable_Complete (PatchTarget p)

23+ deriving (Generic)

24+

25+completePatchable :: Patchable p -> Maybe (PatchTarget p)

26+completePatchable = \case

27+ Patchable_Complete t -> Just t

28+ Patchable_Patch _ -> Nothing

29+

30+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)

31+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)

32+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)

33+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)

34+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)

35+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)

36+

37+instance (Monoid p, Patch p) => Monoid (Patchable p) where

38+ mempty = Patchable_Patch mempty

39+ mappend = (<>)

40+

41+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where

42+ (<>) = curry $ \case

43+ (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b

44+ (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b

45+ (Patchable_Complete a, _) -> Patchable_Complete a