develop...d72221c · patch

git.iko.soy/patch

11 files changed+475−75

since splitsnapshots

unifiedsplit

ChangeLog.md+4 patch.cabal+2 src/Data/Patch.hs+7−5 src/Data/Patch/Class.hs+84−6 src/Data/Patch/DMap.hs+3−1 src/Data/Patch/DMapWithMove.hs+196−58 src/Data/Patch/DMapWithReset.hs+120 src/Data/Patch/IntMap.hs+3−1 src/Data/Patch/Map.hs+3−1 src/Data/Patch/MapWithMove.hs+8−3 src/Data/Patch/Patchable.hs+45

ChangeLog.md+4

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

55* `PatchMapWithMove` supports moves with a patch.

7+* Add `PatchDMapWithReset`

9+* Add `Patchable`

10+

711## 0.0.1.0

812

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

patch.cabal+2

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

4444 , Data.Patch.Class

4545 , Data.Patch.DMap

4646 , Data.Patch.DMapWithMove

47+ , Data.Patch.DMapWithReset

4748 , Data.Patch.IntMap

4849 , Data.Patch.Map

4950 , Data.Patch.MapWithMove

51+ , Data.Patch.Patchable

5052

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

5254

src/Data/Patch.hs+7−5

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

@@ -62,8 +64,8 @@ instance (Ord k, Additive q) => Additive (MonoidalMap k q)

6264

6365-- | Trivial group.

6466instance Group () where

65− negateG _ = ()

66− _ ~~ _ = ()

67+ negateG ~() = ()

68+ ~() ~~ ~() = ()

6769instance Additive ()

6870

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

8890

8991-- | Trivial group, Functor style

9092instance Group (Proxy x) where

91− negateG _ = Proxy

92− _ ~~ _ = Proxy

93+ negateG ~Proxy = Proxy

94+ ~Proxy ~~ ~Proxy = Proxy

9395instance Additive (Proxy x)

9496

9597-- | Const lifts groups into a functor.

src/Data/Patch/Class.hs+84−6

@@ -1,4 +1,10 @@

1+{-# LANGUAGE DefaultSignatures #-}

2+{-# LANGUAGE DeriveTraversable #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE QuantifiedConstraints #-}

16{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

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

39module Data.Patch.Class where

410

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

612import Data.Maybe

713import Data.Semigroup (Semigroup(..))

814import Data.Proxy

15+import Data.Type.Equality ((:~:) (..))

16+

17+class PatchHet p where

18+ type PatchSource p :: *

19+ type PatchTarget p :: *

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

21+ -- 'Nothing'.

22+ applyHet

23+ :: p

24+ -> PatchSource p

25+ -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)

26+ default applyHet

27+ :: Patch p

28+ => p

29+ -> PatchSource p

30+ -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)

31+ applyHet p a = case apply p a of

32+ Nothing -> Left Refl

33+ Just a' -> Right a'

34+

35+-- | Apply a 'PatchHet'; if it does nothing, return the original value

36+applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p

37+applyAlwaysHet p t = case applyHet p t of

38+ Left Refl -> t

39+ Right t' -> t'

940

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

1142--

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

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

14−class Patch p where

15− type PatchTarget p :: *

45+class ( PatchHet p

46+ , PatchSource p ~ PatchTarget p

47+ ) => Patch p where

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

1749 -- 'Nothing'.

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

@@ -22,19 +54,65 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p

2254applyAlways p t = fromMaybe t $ apply p t

2355

2456-- | 'Identity' can be used as a 'Patch' that always fully replaces the value

25−instance Patch (Identity a) where

57+instance PatchHet (Identity a) where

58+ type PatchSource (Identity a) = a

2659 type PatchTarget (Identity a) = a

60+instance Patch (Identity a) where

2761 apply (Identity a) _ = Just a

2862

29−-- | 'Identity' can be used as a 'Patch' that always fully replaces the value

30−instance Patch (Proxy a) where

63+-- | 'Proxy' can be used as a 'Patch' that always fully replaces the value

64+instance PatchHet (Proxy (a :: *)) where

65+ type PatchSource (Proxy a) = a

3166 type PatchTarget (Proxy a) = a

67+instance Patch (Proxy (a :: *)) where

3268 apply ~Proxy _ = Nothing

3369

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

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

3672-- apply patches right-to-left, like '(.)'.

37−composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p

73+composePatchFunctions

74+ :: (Patch p, Semigroup p)

75+ => (PatchTarget p -> p)

76+ -> (PatchTarget p -> p)

77+ -> PatchTarget p -> p

3878composePatchFunctions g f a =

3979 let fp = f a

4080 in g (applyAlways fp a) <> fp

81+

82+class (forall x y

83+ . ( PatchHet (p x y)

84+ , PatchSource1 p x ~ PatchSource (p x y)

85+ , PatchTarget1 p y ~ PatchTarget (p x y)

86+ )

87+ ) => PatchHet2 (p :: k -> k -> *) where

88+ type PatchSource1 p :: k -> *

89+ type PatchTarget1 p :: k -> *

90+

91+class ( PatchHet2 p

92+ , PatchSource1 p ~ PatchTarget1 p

93+ ) => Patch2 p

94+instance ( PatchHet2 p

95+ , PatchSource1 p ~ PatchTarget1 p

96+ ) => Patch2 p

97+

98+newtype Replace2 (t :: k -> *) (a :: k) (b :: k) = Replace2 (t b)

99+ deriving ( Show, Read, Eq, Ord

100+ , Functor, Foldable, Traversable

101+ )

102+

103+data Proxy2 t a b = Proxy2

104+ deriving ( Show, Read, Eq, Ord

105+ , Functor, Foldable, Traversable

106+ )

107+

108+-- | 'Replace2' can be used as a 'Patch' that always fully replaces the value

109+instance PatchHet (Replace2 (t :: k -> *) (a :: k) (b :: k)) where

110+ type PatchSource (Replace2 t a b) = t a

111+ type PatchTarget (Replace2 t a b) = t b

112+ applyHet (Replace2 val) _ = Right val

113+

114+-- | 'Proxy2' can be used as a 'Patch' that always fully replaces the value

115+instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where

116+ type PatchSource (Proxy2 t a a) = t a

117+ type PatchTarget (Proxy2 t a a) = t a

118+ applyHet ~Proxy2 _ = Left Refl

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+196−58

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE GADTs #-}

@@ -8,8 +9,11 @@

89{-# LANGUAGE PolyKinds #-}

910{-# LANGUAGE Rank2Types #-}

1011{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TypeApplications #-}

1114{-# LANGUAGE TypeFamilies #-}

1215{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE UndecidableSuperClasses #-}

1317

1418-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and

1519-- move values between keys.

@@ -20,19 +24,34 @@ import Data.Patch.MapWithMove (PatchMapWithMove (..))

2024import qualified Data.Patch.MapWithMove as MapWithMove

2125

2226import Data.Constraint.Extras

27+import Data.Constraint.Compose

2328import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

2429import qualified Data.Dependent.Map as DMap

2530import Data.Functor.Constant

2631import Data.Functor.Misc

2732import Data.Functor.Product

28−import Data.GADT.Compare (GEq (..))

29−import Data.GADT.Show (GShow, gshow)

33+import Data.GADT.Compare (GEq (..), GCompare)

34+import Data.GADT.Show (GRead, GShow, gshow)

3035import qualified Data.Map as Map

3136import Data.Maybe

37+import Data.Monoid.DecidablyEmpty

3238import Data.Semigroup (Semigroup (..), (<>))

3339import Data.Some (Some(Some))

3440import Data.Proxy

3541import Data.These

42+import Data.Type.Equality ((:~:) (..))

43+import Data.Kind (Constraint)

44+

45+

46+-- | Composition for constraints.

47+class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)

48+instance p (f a a) => DupC p f a

49+

50+type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =

51+ ConstraintsFor f (DupC c g)

52+

53+type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =

54+ (ArgDict (DupC c g) f, ConstraintsForZip f c g)

3655

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

3857-- destinations.

@@ -43,59 +62,131 @@ import Data.These

4362-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)

4463newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

4564

65+deriving instance ( GShow k

66+ , HasZip Show k p

67+ , Has' Show k (PatchTarget1 p)

68+ ) => Show (PatchDMapWithMove k p)

69+deriving instance ( GRead k

70+ , HasZip Read k p

71+ , Has' Read k (PatchTarget1 p)

72+ ) => Read (PatchDMapWithMove k p)

73+deriving instance ( GEq k

74+ , HasZip Eq k p

75+ , Has' Eq k (PatchTarget1 p)

76+ ) => Eq (PatchDMapWithMove k p)

77+deriving instance ( GCompare k

78+ , HasZip Ord k p

79+ , Has' Ord k (PatchTarget1 p)

80+ ) => Ord (PatchDMapWithMove k p)

81+

4682-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key

4783-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.

48−data NodeInfo k v a = NodeInfo

49− { _nodeInfo_from :: !(From k v a)

84+data NodeInfo k p a = NodeInfo

85+ { _nodeInfo_from :: !(From k p a)

5086 -- ^Change applying to the current key, be it an insert, move, or delete.

51− , _nodeInfo_to :: !(To k a)

87+ , _nodeInfo_to :: !(Some (To k))

5288 -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.

5389 }

54− deriving (Show)

90+

91+deriving instance ( Show (k a)

92+ , Show (p a a)

93+ , Show (PatchTarget1 p a)

94+ ) => Show (NodeInfo k p a)

95+deriving instance ( Read (k a)

96+ , Read (p a a)

97+ , Read (PatchTarget1 p a)

98+ ) => Read (NodeInfo k p a)

99+deriving instance ( Eq (k a)

100+ , Eq (p a a)

101+ , Eq (PatchTarget1 p a)

102+ ) => Eq (NodeInfo k p a)

103+deriving instance ( Ord (k a)

104+ , Ord (p a a)

105+ , Ord (PatchTarget1 p a)

106+ ) => Ord (NodeInfo k p a)

55107

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

57109-- key (@From_Delete@), or moving a key (@From_Move@).

58−data From (k :: a -> *) (v :: a -> *) :: a -> * where

59− -- |Insert a new or update an existing key with the given value @v a@

60− From_Insert :: v a -> From k v a

110+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where

111+ -- |Insert a new or update an existing key with the given value @PatchTarget1 p a@

112+ From_Insert :: PatchTarget1 p a -> From k p a

61113 -- |Delete the existing key

62− From_Delete :: From k v a

114+ From_Delete :: From k p a

63115 -- |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@,

64116 -- usually but not necessarily with @From_Delete@.

65− From_Move :: !(k a) -> From k v a

66− deriving (Show, Read, Eq, Ord)

117+ From_Move :: !(k a0) -> p a0 a1 -> From k p a1

118+

119+deriving instance ( Show (k a)

120+ , Show (p a a)

121+ , Show (PatchTarget1 p a)

122+ ) => Show (From k p a)

123+deriving instance ( Read (k a)

124+ , Read (p a a)

125+ , Read (PatchTarget1 p a)

126+ ) => Read (From k p a)

127+

128+instance ( GEq k

129+ , HasZip Eq k p

130+ , Eq (PatchTarget1 p a)

131+ ) => Eq (From k p a) where

132+ From_Insert p0 == From_Insert p1 = p0 == p1

133+ From_Delete == From_Delete = True

134+ From_Move k0 p0 == From_Move k1 p1 = case geq k0 k1 of

135+ Nothing -> False

136+ Just Refl -> has @(DupC Eq p) k0 $ p0 == p1

137+

138+instance ( GCompare k

139+ , HasZip Ord k p

140+ , Ord (PatchTarget1 p a)

141+ ) => Ord (From k p a) where

142+ From_Insert p0 `compare` From_Insert p1 = p0 `compare` p1

143+ From_Delete `compare` From_Delete = EQ

144+ From_Move k0 p0 `compare` From_Move k1 p1 = case gcompare k0 k1 of

145+ DMap.GGT -> GT

146+ DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1

147+ DMap.GLT -> LT

67148

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

69150-- operation.

70151type To = ComposeMaybe

71152

72153-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.

73−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool

154+validPatchDMapWithMove

155+ :: forall k v

156+ . (GCompare k, GShow k)

157+ => DMap k (NodeInfo k v)

158+ -> Bool

74159validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

75160

76161-- |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]

162+validationErrorsForPatchDMapWithMove

163+ :: forall k v

164+ . (GCompare k, GShow k)

165+ => DMap k (NodeInfo k v)

166+ -> [String]

78167validationErrorsForPatchDMapWithMove m =

79168 noSelfMoves <> movesBalanced

80169 where

81170 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

82− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"

83− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"

171+ selfMove (dst :=> NodeInfo (From_Move src _) _)

172+ | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"

173+ selfMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst))))

174+ | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"

84175 selfMove _ = Nothing

85176 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

86− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =

177+ unbalancedMove (dst :=> NodeInfo (From_Move src _) _) =

87178 case DMap.lookup src m of

88179 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'))) ->

180+ Just (NodeInfo _ (Some (ComposeMaybe (Just dst')))) ->

90181 if isNothing (dst' `geq` dst)

91182 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"

92183 else Nothing

93184 _ ->

94185 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))) =

186+ unbalancedMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst)))) =

96187 case DMap.lookup dst m of

97188 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') _) ->

189+ Just (NodeInfo (From_Move src' _) _) ->

99190 if isNothing (src' `geq` src)

100191 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"

101192 else Nothing

@@ -104,33 +195,39 @@ validationErrorsForPatchDMapWithMove m =

104195 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"

105196 unbalancedMove _ = Nothing

106197

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−

111198-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9

112199data Pair1 f g a = Pair1 (f a) (g a)

113200

201+data PairHalf a f b = PairHalf a (f b)

202+

114203-- |Helper data structure used for composing patches using the monoid instance.

115204data Fixup k v a

116205 = Fixup_Delete

117206 | Fixup_Update (These (From k v a) (To k a))

118207

119208-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

120−instance GCompare k => Semigroup (PatchDMapWithMove k v) where

209+instance ( GCompare k

210+ -- , DecidablyEmpty p

211+ , PatchHet2 p

212+ ) => Semigroup (PatchDMapWithMove k p) where

121213 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

122214 where

123− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb

124− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]

125− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of

126− (Just toAfter, From_Move fromBefore)

127− | isJust $ fromBefore `geq` toAfter

215+ connections = DMap.toList $ DMap.intersectionWithKey

216+ (\_ a b -> PairHalf (_nodeInfo_to a) (_nodeInfo_from b))

217+ ma

218+ mb

219+ h :: DSum k (PairHalf (Some (ComposeMaybe k)) (From k v)) -> [DSum k (Fixup k v)]

220+ h (between :=> PairHalf (Some (ComposeMaybe mToAfter)) editBefore) = case (mToAfter, editBefore) of

221+ (Just toAfter, From_Move fromBefore p)

222+ | case fromBefore `geq` toAfter of

223+ Nothing -> False

224+ Just Refl -> isNull p

128225 -> [toAfter :=> Fixup_Delete]

129226 | otherwise

130227 -> [ toAfter :=> Fixup_Update (This editBefore)

131228 , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))

132229 ]

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

230+ (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

134231 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]

135232 (Nothing, _) -> []

136233 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

@@ -148,7 +245,13 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where

148245 applyFixup _ ni = \case

149246 Fixup_Delete -> Nothing

150247 Fixup_Update u -> Just $ NodeInfo

151− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u

248+ { _nodeInfo_from = case _nodeInfo_from ni of

249+ f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch

250+ Nothing -> f -- If there's no `from` fixup, just use the "new" `from`

251+ Just (From_Insert v) -> From_Insert $ applyAlways p' v

252+ Just From_Delete -> From_Delete

253+ Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p

254+ _ -> error "DPatchMapWithMove: fixup for non-move From"

152255 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

153256 }

154257 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups

@@ -169,7 +272,7 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where

169272 mappend = (<>)

170273

171274{-

172−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v

275+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v

173276PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src

174277 where

175278 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,8 +293,8 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith

190293 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore

191294-}

192295

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

194−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v

296+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @PatchTarget1 p a@ to the given key @k a@, like 'DMap.insert'.

297+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p

195298insertDMapKey k v =

196299 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)

197300

@@ -272,41 +375,67 @@ patchDMapWithMove dm =

272375 errs -> Left errs

273376

274377-- |Map a natural transform @v -> v'@ over the given patch, transforming @'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'

378+mapPatchDMapWithMove

379+ :: forall k p p'

380+ . (forall a. PatchTarget1 p a -> PatchTarget1 p' a)

381+ -> PatchDMapWithMove k p

382+ -> PatchDMapWithMove k p'

276383mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

277384 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p

278− where g :: forall a. From k v a -> From k v' a

385+ where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a

279386 g = \case

280387 From_Insert v -> From_Insert $ f v

281388 From_Delete -> From_Delete

282389 From_Move k -> From_Move k

283390

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')@.

285−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

391+-- |Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.

392+traversePatchDMapWithMove

393+ :: forall m k p p'

394+ . Applicative m

395+ => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))

396+ -> PatchDMapWithMove k p

397+ -> m (PatchDMapWithMove k p')

286398traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

287399

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')@.

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

290−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

291− where g :: forall a. k a -> From k v a -> m (From k v' a)

400+-- |Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.

401+traversePatchDMapWithMoveWithKey

402+ :: forall m k p p'

403+ . Applicative m

404+ => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))

405+ -> PatchDMapWithMove k p

406+ -> m (PatchDMapWithMove k p')

407+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =

408+ PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

409+ where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)

292410 g k = \case

293411 From_Insert v -> From_Insert <$> f k v

294412 From_Delete -> pure From_Delete

295413 From_Move fromKey -> pure $ From_Move fromKey

296414

297−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.

298−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

415+-- |Map a function which transforms @'From' k PatchTarget1 p a@ into a @'From' k PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.

416+nodeInfoMapFrom

417+ :: (From k p a -> From k p' a)

418+ -> NodeInfo k p a

419+ -> NodeInfo k p' a

299420nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

300421

301−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.

302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

422+-- |Map an effectful function which transforms @'From' k PatchTarget1 p a@ into a @f ('From' k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.

423+nodeInfoMapFromM

424+ :: Functor f

425+ => (From k p a -> f (From k p' a))

426+ -> NodeInfo k p a

427+ -> f (NodeInfo k p' a)

303428nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

304429

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

430+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @PatchTarget1 p a -> v'@ to

306431-- values.

307−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) (Proxy v')

432+weakenPatchDMapWithMoveWith

433+ :: forall k p v'

434+ . (forall a. PatchTarget1 p a -> v')

435+ -> PatchDMapWithMove k p

436+ -> PatchMapWithMove (Some k) (Proxy v')

308437weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

309− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) (Proxy v')

438+ where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')

310439 g ni = MapWithMove.NodeInfo

311440 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

312441 From_Insert v -> MapWithMove.From_Insert $ f v

@@ -317,9 +446,12 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD

317446

318447-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any

319448-- dependency in the typing and all points are already @a@, hence the function 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')

449+patchDMapWithMoveToPatchMapWithMoveWith

450+ :: forall k p v' a. (PatchTarget1 p a -> v')

451+ -> PatchDMapWithMove (Const2 k a) p

452+ -> PatchMapWithMove k (Proxy v')

321453patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

322− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k (Proxy v')

454+ where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')

323455 g ni = MapWithMove.NodeInfo

324456 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

325457 From_Insert v -> MapWithMove.From_Insert $ f v

@@ -329,9 +461,13 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo

329461 }

330462

331463-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed

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@.

464+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p' a@.

333465-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

334−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'

466+const2PatchDMapWithMoveWith

467+ :: forall k v p' a

468+ . (v -> PatchTarget1 p' a)

469+ -> PatchMapWithMove k (Proxy v)

470+ -> PatchDMapWithMove (Const2 k a) p'

335471const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

336472 where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')

337473 g (k, ni) = Const2 k :=> NodeInfo

@@ -343,17 +479,19 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr

343479 }

344480

345481-- | Apply the insertions, deletions, and moves to a given 'DMap'.

346−instance GCompare k => Patch (PatchDMapWithMove k v) where

347− type PatchTarget (PatchDMapWithMove k v) = DMap k v

482+instance GCompare k => PatchHet (PatchDMapWithMove k p) where

483+ type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)

484+ type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)

485+instance GCompare k => Patch (PatchDMapWithMove k p) where

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

349487 where insertions = DMap.mapMaybeWithKey insertFunc p

350− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)

488+ insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)

351489 insertFunc _ ni = case _nodeInfo_from ni of

352490 From_Insert v -> Just v

353491 From_Move k -> DMap.lookup k old

354492 From_Delete -> Nothing

355493 deletions = DMap.mapMaybeWithKey deleteFunc p

356− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)

494+ deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)

357495 deleteFunc _ ni = case _nodeInfo_from ni of

358496 From_Delete -> Just $ Constant ()

359497 _ -> Nothing

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

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−3

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

@@ -252,7 +258,6 @@ data Fixup k v

252258

253259-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

254260instance ( Ord k

255− , Monoid p

256261 , DecidablyEmpty p

257262 , Patch p

258263 ) => Semigroup (PatchMapWithMove k p) where

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 #-}

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