develop...d72221c · patch

git.iko.soy/patch

on d72221c help sign in

ChangeLog.md+4

since splitsnapshots

unifiedsplit

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

5* `PatchMapWithMove` supports moves with a patch.

7+* Add `PatchDMapWithReset`

9+* Add `Patchable`

10+

7## 0.0.1.0

11## 0.0.1.0

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

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

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

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 }

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

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)

63-- | Trivial group.

65-- | Trivial group.

64instance Group () where

66instance Group () where

65− negateG _ = ()

67+ negateG ~() = ()

66− _ ~~ _ = ()

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

67instance Additive ()

69instance Additive ()

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)

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)

95-- | Const lifts groups into a functor.

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

1{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

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

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

3module Data.Patch.Class where

9module Data.Patch.Class where

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

6import Data.Maybe

12import Data.Maybe

7import Data.Semigroup (Semigroup(..))

13import Data.Semigroup (Semigroup(..))

8import Data.Proxy

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

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

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

11--

42--

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

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

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

45+class ( PatchHet p

46+ , PatchSource p ~ PatchTarget p

14−class Patch p where

47+ ) => Patch p where

15− type PatchTarget p :: *

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

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

17 -- 'Nothing'.

49 -- 'Nothing'.

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

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

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

22applyAlways p t = fromMaybe t $ apply p t

54applyAlways p t = fromMaybe t $ apply p t

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

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

26 type PatchTarget (Identity a) = a

59 type PatchTarget (Identity a) = a

60+instance Patch (Identity a) where

27 apply (Identity a) _ = Just a

61 apply (Identity a) _ = Just a

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

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

30−instance Patch (Proxy a) where

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

65+ type PatchSource (Proxy a) = a

31 type PatchTarget (Proxy a) = a

66 type PatchTarget (Proxy a) = a

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

32 apply ~Proxy _ = Nothing

68 apply ~Proxy _ = Nothing

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

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

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

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

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

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

38composePatchFunctions g f a =

78composePatchFunctions g f a =

39 let fp = f a

79 let fp = f a

40 in g (applyAlways fp a) <> fp

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

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

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

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

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

8{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE Rank2Types #-}

10{-# LANGUAGE Rank2Types #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TypeApplications #-}

11{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE UndecidableSuperClasses #-}

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.

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

20import qualified Data.Patch.MapWithMove as MapWithMove

24import qualified Data.Patch.MapWithMove as MapWithMove

22import Data.Constraint.Extras

26import Data.Constraint.Extras

27+import Data.Constraint.Compose

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

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

24import qualified Data.Dependent.Map as DMap

29import qualified Data.Dependent.Map as DMap

25import Data.Functor.Constant

30import Data.Functor.Constant

26import Data.Functor.Misc

31import Data.Functor.Misc

27import Data.Functor.Product

32import Data.Functor.Product

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

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

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

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

30import qualified Data.Map as Map

35import qualified Data.Map as Map

31import Data.Maybe

36import Data.Maybe

37+import Data.Monoid.DecidablyEmpty

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

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

33import Data.Some (Some(Some))

39import Data.Some (Some(Some))

34import Data.Proxy

40import Data.Proxy

35import Data.These

41import 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)

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

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

38-- destinations.

57-- destinations.

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

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

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

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

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

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+

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

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

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

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

84+data NodeInfo k p a = NodeInfo

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

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

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

86 -- ^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))

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

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

53 }

89 }

90+

54− deriving (Show)

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)

107

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

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

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

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

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

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

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

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

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

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

61 -- |Delete the existing key

113 -- |Delete the existing key

62− From_Delete :: From k v a

114+ From_Delete :: From k p a

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

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

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

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

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

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

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

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

148

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

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

69-- operation.

150-- operation.

70type To = ComposeMaybe

151type To = ComposeMaybe

152

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

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

74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

159validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

160

76-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.

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

78validationErrorsForPatchDMapWithMove m =

167validationErrorsForPatchDMapWithMove m =

79 noSelfMoves <> movesBalanced

168 noSelfMoves <> movesBalanced

80 where

169 where

81 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

170 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

171+ 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"

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

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

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

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

84 selfMove _ = Nothing

175 selfMove _ = Nothing

85 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

176 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

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

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

87 case DMap.lookup src m of

178 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"

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

90 if isNothing (dst' `geq` dst)

181 if isNothing (dst' `geq` dst)

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

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

92 else Nothing

183 else Nothing

93 _ ->

184 _ ->

94 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"

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

96 case DMap.lookup dst m of

187 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"

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

99 if isNothing (src' `geq` src)

190 if isNothing (src' `geq` src)

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

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

101 else Nothing

192 else Nothing

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

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

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

105 unbalancedMove _ = Nothing

196 unbalancedMove _ = Nothing

106

197

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

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

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

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

113

200

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

202+

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

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

115data Fixup k v a

204data Fixup k v a

116 = Fixup_Delete

205 = Fixup_Delete

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

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

118

207

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

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

209+instance ( GCompare k

210+ -- , DecidablyEmpty p

211+ , PatchHet2 p

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

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

121 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

213 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

122 where

214 where

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

215+ connections = DMap.toList $ DMap.intersectionWithKey

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

217+ ma

218+ mb

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

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

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

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

126− (Just toAfter, From_Move fromBefore)

221+ (Just toAfter, From_Move fromBefore p)

127− | isJust $ fromBefore `geq` toAfter

222+ | case fromBefore `geq` toAfter of

223+ Nothing -> False

224+ Just Refl -> isNull p

128 -> [toAfter :=> Fixup_Delete]

225 -> [toAfter :=> Fixup_Delete]

129 | otherwise

226 | otherwise

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

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

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

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

132 ]

229 ]

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

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

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

135 (Nothing, _) -> []

232 (Nothing, _) -> []

136 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

233 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

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

148 applyFixup _ ni = \case

245 applyFixup _ ni = \case

149 Fixup_Delete -> Nothing

246 Fixup_Delete -> Nothing

150 Fixup_Update u -> Just $ NodeInfo

247 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"

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

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

153 }

256 }

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

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

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

169 mappend = (<>)

272 mappend = (<>)

170

273

171{-

274{-

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

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

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

174 where

277 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

278 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

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

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

191-}

294-}

192

295

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

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

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

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

195insertDMapKey k v =

298insertDMapKey k v =

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

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

197

300

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

272 errs -> Left errs

375 errs -> Left errs

273

376

274-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.

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

276mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

383mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

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

384 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

279 g = \case

386 g = \case

280 From_Insert v -> From_Insert $ f v

387 From_Insert v -> From_Insert $ f v

281 From_Delete -> From_Delete

388 From_Delete -> From_Delete

282 From_Move k -> From_Move k

389 From_Move k -> From_Move k

283

390

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

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

285−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> 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')

286traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

398traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

287

399

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

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

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

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

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

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

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

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

292 g k = \case

410 g k = \case

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

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

294 From_Delete -> pure From_Delete

412 From_Delete -> pure From_Delete

295 From_Move fromKey -> pure $ From_Move fromKey

413 From_Move fromKey -> pure $ From_Move fromKey

296

414

297−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over 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@.

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

416+nodeInfoMapFrom

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

418+ -> NodeInfo k p a

419+ -> NodeInfo k p' a

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

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

300

421

301−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'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@.

302−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' 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)

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

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

304

429

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

306-- values.

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

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

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

310 g ni = MapWithMove.NodeInfo

439 g ni = MapWithMove.NodeInfo

311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

440 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

312 From_Insert v -> MapWithMove.From_Insert $ f v

441 From_Insert v -> MapWithMove.From_Insert $ f v

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

317

446

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

447-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k 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.

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

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

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

323 g ni = MapWithMove.NodeInfo

455 g ni = MapWithMove.NodeInfo

324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

456 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

325 From_Insert v -> MapWithMove.From_Insert $ f v

457 From_Insert v -> MapWithMove.From_Insert $ f v

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

329 }

461 }

330

462

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

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

333-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

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

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

471const2PatchDMapWithMoveWith f (PatchMapWithMove p) = 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')

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

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

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

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

343 }

479 }

344

480

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

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

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

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

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

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

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

485+instance GCompare k => 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?

486 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

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

351 insertFunc _ ni = case _nodeInfo_from ni of

489 insertFunc _ ni = case _nodeInfo_from ni of

352 From_Insert v -> Just v

490 From_Insert v -> Just v

353 From_Move k -> DMap.lookup k old

491 From_Move k -> DMap.lookup k old

354 From_Delete -> Nothing

492 From_Delete -> Nothing

355 deletions = DMap.mapMaybeWithKey deleteFunc p

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

357 deleteFunc _ ni = case _nodeInfo_from ni of

495 deleteFunc _ ni = case _nodeInfo_from ni of

358 From_Delete -> Just $ Constant ()

496 From_Delete -> Just $ Constant ()

359 _ -> Nothing

497 _ -> 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

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

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)

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

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

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

252

258

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

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

254instance ( Ord k

260instance ( Ord k

255− , Monoid p

256 , DecidablyEmpty p

261 , DecidablyEmpty p

257 , Patch p

262 , Patch p

258 ) => Semigroup (PatchMapWithMove k p) where

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