4f8ae56 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

WIP Merge remote-tracking branch 'origin/develop' into patch-map-inner-patch

4f8ae56John Ericson7 years ago

ChangeLog.md+13−1

compare with develop

unifiedsplit

@@ -2,7 +2,19 @@

3## Unreleased

5−* `PatchMapWithMove` supports moves with a patch.

5+* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.

7+## 0.0.2.0

9+* Consistently provide:

10+

11+ - `Wrapped` instances

12+

13+ - `*WithIndex` instances

14+

15+ - `un*` newtype unwrappers

16+

17+ for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.

7## 0.0.1.0

19## 0.0.1.0

patch.cabal+3−1

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

1Name: patch

2−Version: 0.0.1.0

2+Version: 0.0.2.0

3Synopsis: Infrastructure for writing patches which act on other types.

4Description:

5 In this library, a patch is something which can be applied, analogous to a

@@ -35,6 +35,7 @@ library

35 , containers >= 0.6 && < 0.7

36 , dependent-map >= 0.3 && < 0.4

37 , dependent-sum >= 0.6 && < 0.7

38+ , lens >= 4.7 && < 5

38 , semigroupoids >= 4.0 && < 6

39 , semigroupoids >= 4.0 && < 6

39 , transformers >= 0.5.6.0 && < 0.6

40 , transformers >= 0.5.6.0 && < 0.6

40 , witherable >= 0.3 && < 0.3.2

41 , witherable >= 0.3 && < 0.3.2

@@ -48,6 +49,7 @@ library

48 , Data.Patch.IntMap

49 , Data.Patch.IntMap

49 , Data.Patch.Map

50 , Data.Patch.Map

50 , Data.Patch.MapWithMove

51 , Data.Patch.MapWithMove

52+ , Data.Patch.MapWithPatchingMove

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

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

release.nix+20−10

@@ -18,16 +18,26 @@ let

18 "ghcIosAarch64"

19 ];

20 compilerPkgs = lib.genAttrs compilers (ghc: let

21+ reflex-platform = reflex-platform-fun {

22+ inherit system;

23+ haskellOverlays = [

24+ # Use this package's source for reflex

25+ (self: super: {

26+ _dep = super._dep // {

21− src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [

27+ patch = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [

22− "release.nix"

28+ "release.nix"

23− ".git"

29+ ".git"

24− "dist"

30+ "dist"

25− "dist-newstyle"

31+ "dist-newstyle"

26− "cabal.haskell-ci"

32+ "cabal.haskell-ci"

27− "cabal.project"

33+ "cabal.project"

28− ".travis.yml"

34+ ".travis.yml"

29− ])) ./.;

35+ ])) ./.;

36+ };

37+ })

38+ ];

39+ };

30− in reflex-platform.${ghc}.callCabal2nix "patch" src {});

40+ in reflex-platform.${ghc}.patch);

31 in compilerPkgs // {

41 in compilerPkgs // {

32 cache = reflex-platform.pinBuildInputs "patch-${system}"

42 cache = reflex-platform.pinBuildInputs "patch-${system}"

33 (builtins.attrValues compilerPkgs);

43 (builtins.attrValues compilerPkgs);

src/Data/Patch/IntMap.hs+24−10

@@ -1,12 +1,15 @@

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveTraversable #-}

1{-# LANGUAGE DeriveTraversable #-}

2+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for

8-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for

7-- insert/update or delete of associations.

9-- insert/update or delete of associations.

8module Data.Patch.IntMap where

10module Data.Patch.IntMap where

12+import Control.Lens

10import Data.IntMap.Strict (IntMap)

13import Data.IntMap.Strict (IntMap)

11import qualified Data.IntMap.Strict as IntMap

14import qualified Data.IntMap.Strict as IntMap

12import Data.Maybe

15import Data.Maybe

@@ -16,7 +19,20 @@ import Data.Patch.Class

16-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.

19-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.

17-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update

20-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update

18-- and @Nothing@ means delete.

21-- and @Nothing@ means delete.

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

22+newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }

23+ deriving ( Show, Read, Eq, Ord

24+ , Functor, Foldable, Traversable, Monoid

25+ )

26+

27+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

28+-- If the same key is modified by both patches, the one on the left will take

29+-- precedence.

30+instance Semigroup (PatchIntMap v) where

31+ PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map

32+ -- PatchMap is idempotent, so stimes n is id for every n

33+ stimes = stimesIdempotentMonoid

34+

35+makeWrapped ''PatchIntMap

21-- | Apply the insertions or deletions to a given 'IntMap'.

37-- | Apply the insertions or deletions to a given 'IntMap'.

22instance Patch (PatchIntMap a) where

38instance Patch (PatchIntMap a) where

@@ -26,13 +42,11 @@ instance Patch (PatchIntMap a) where

26 adds = IntMap.mapMaybe id p

42 adds = IntMap.mapMaybe id p

27 in IntMap.union adds $ v `IntMap.difference` removes

43 in IntMap.union adds $ v `IntMap.difference` removes

29−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

45+instance FunctorWithIndex Int PatchIntMap

30−-- If the same key is modified by both patches, the one on the left will take

46+instance FoldableWithIndex Int PatchIntMap

31−-- precedence.

47+instance TraversableWithIndex Int PatchIntMap where

32−instance Semigroup (PatchIntMap v) where

48+ itraverse = itraversed . Indexed

33− PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map

49+ itraversed = _Wrapped .> itraversed <. traversed

34− -- PatchMap is idempotent, so stimes n is id for every n

35− stimes = stimesIdempotentMonoid

37-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@

51-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@

38-- (that is, all inserts/updates), producing a @PatchIntMap b@.

52-- (that is, all inserts/updates), producing a @PatchIntMap b@.

src/Data/Patch/Map.hs+29−13

@@ -1,11 +1,18 @@

1+{-# LANGUAGE DeriveTraversable #-}

2+{-# LANGUAGE FlexibleInstances #-}

1{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE StandaloneDeriving #-}

6+{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

3-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)

9-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)

4-- and deletions

10-- and deletions

5module Data.Patch.Map where

11module Data.Patch.Map where

7import Data.Patch.Class

13import Data.Patch.Class

15+import Control.Lens

9import Data.Map (Map)

16import Data.Map (Map)

10import qualified Data.Map as Map

17import qualified Data.Map as Map

11import Data.Maybe

18import Data.Maybe

@@ -15,7 +22,23 @@ import Data.Semigroup

15-- deleted. Insertions are represented as values wrapped in 'Just', while

22-- deleted. Insertions are represented as values wrapped in 'Just', while

16-- deletions are represented as 'Nothing's

23-- deletions are represented as 'Nothing's

17newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

24newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

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

25+ deriving ( Show, Read, Eq, Ord

26+ , Foldable, Traversable

27+ )

28+

29+-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.

30+-- Deletions are unaffected.

31+deriving instance Functor (PatchMap k)

32+

33+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

34+-- If the same key is modified by both patches, the one on the left will take

35+-- precedence.

36+instance Ord k => Semigroup (PatchMap k v) where

37+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

38+ -- PatchMap is idempotent, so stimes n is id for every n

39+ stimes = stimesIdempotentMonoid

40+

41+makeWrapped ''PatchMap

20-- | Apply the insertions or deletions to a given 'Map'.

43-- | Apply the insertions or deletions to a given 'Map'.

21instance Ord k => Patch (PatchMap k v) where

44instance Ord k => Patch (PatchMap k v) where

@@ -28,24 +51,17 @@ instance Ord k => Patch (PatchMap k v) where

28 Nothing -> Just ()

51 Nothing -> Just ()

29 Just _ -> Nothing

52 Just _ -> Nothing

31−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

54+instance FunctorWithIndex k (PatchMap k)

32−-- If the same key is modified by both patches, the one on the left will take

55+instance FoldableWithIndex k (PatchMap k)

33−-- precedence.

34−instance Ord k => Semigroup (PatchMap k v) where

56+instance TraversableWithIndex k (PatchMap k) where

35− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

57+ itraverse = itraversed . Indexed

36− -- PatchMap is idempotent, so stimes n is id for every n

58+ itraversed = _Wrapped .> itraversed <. traversed

37− stimes = stimesIdempotentMonoid

39-- | The empty 'PatchMap' contains no insertions or deletions

60-- | The empty 'PatchMap' contains no insertions or deletions

40instance Ord k => Monoid (PatchMap k v) where

61instance Ord k => Monoid (PatchMap k v) where

41 mempty = PatchMap mempty

62 mempty = PatchMap mempty

42 mappend = (<>)

63 mappend = (<>)

44−-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.

45−-- Deletions are unaffected.

46−instance Functor (PatchMap k) where

47− fmap f = PatchMap . fmap (fmap f) . unPatchMap

48−

49-- | Returns all the new elements that will be added to the 'Map'

65-- | Returns all the new elements that will be added to the 'Map'

50patchMapNewElements :: PatchMap k v -> [v]

66patchMapNewElements :: PatchMap k v -> [v]

51patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

67patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

src/Data/Patch/MapWithMove.hs+71−115

@@ -1,13 +1,13 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE DeriveTraversable #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE PatternGuards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE StandaloneDeriving #-}

8+{-# LANGUAGE TemplateHaskell #-}

9+{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE UndecidableInstances #-}

12-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

13-- another

@@ -16,6 +16,7 @@ module Data.Patch.MapWithMove where

16import Data.Patch.Class

18import Control.Arrow

19+import Control.Lens hiding (from, to)

19import Control.Monad.Trans.State

20import Control.Monad.Trans.State

20import Data.Foldable

21import Data.Foldable

21import Data.Function

22import Data.Function

@@ -23,97 +24,89 @@ import Data.List

23import Data.Map (Map)

24import Data.Map (Map)

24import qualified Data.Map as Map

25import qualified Data.Map as Map

25import Data.Maybe

26import Data.Maybe

26−--import Data.Proxy

27−#if !MIN_VERSION_base(4,9,0)

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

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

29−#endif

30−import Data.Monoid.DecidablyEmpty

31import qualified Data.Set as Set

28import qualified Data.Set as Set

32−import Data.These (These (..))

29+import Data.These (These(..))

33import Data.Tuple

30import Data.Tuple

35-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@

32-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@

36-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,

33-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,

37-- and vice versa. There should never be any unpaired From/To keys.

34-- and vice versa. There should never be any unpaired From/To keys.

38−newtype PatchMapWithMove k p = PatchMapWithMove

35+newtype PatchMapWithMove k v = PatchMapWithMove

39 { -- | Extract the internal representation of the 'PatchMapWithMove'

36 { -- | Extract the internal representation of the 'PatchMapWithMove'

40− unPatchMapWithMove :: Map k (NodeInfo k p)

37+ unPatchMapWithMove :: Map k (NodeInfo k v)

41 }

38 }

42−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)

39+ deriving ( Show, Read, Eq, Ord

43−deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithMove k p)

40+ , Functor, Foldable, Traversable

44−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)

41+ )

45−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)

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

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

48-- and where its old value should go to

44-- and where its old value should go to

49−data NodeInfo k p = NodeInfo

45+data NodeInfo k v = NodeInfo

50− { _nodeInfo_from :: !(From k p)

46+ { _nodeInfo_from :: !(From k v)

51 -- ^ Where do we get the new value for this key?

47 -- ^ Where do we get the new value for this key?

52 , _nodeInfo_to :: !(To k)

48 , _nodeInfo_to :: !(To k)

53 -- ^ If the old value is being kept (i.e. moved rather than deleted or

49 -- ^ If the old value is being kept (i.e. moved rather than deleted or

54 -- replaced), where is it going?

50 -- replaced), where is it going?

55 }

51 }

56−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)

52+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

57−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)

58−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)

59−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)

61-- | Describe how a key's new value should be produced

54-- | Describe how a key's new value should be produced

62−data From k p

55+data From k v

63− = From_Insert (PatchTarget p) -- ^ Insert the given value here

56+ = From_Insert v -- ^ Insert the given value here

64 | From_Delete -- ^ Delete the existing value, if any, from here

57 | From_Delete -- ^ Delete the existing value, if any, from here

65− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch

58+ | From_Move !k -- ^ Move the value here from the given key

66−

59+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

67−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)

68−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)

69−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)

70−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)

72-- | Describe where a key's old value will go. If this is 'Just', that means

61-- | Describe where a key's old value will go. If this is 'Just', that means

73-- the key's old value will be moved to the given other key; if it is 'Nothing',

62-- the key's old value will be moved to the given other key; if it is 'Nothing',

74-- that means it will be deleted.

63-- that means it will be deleted.

75type To = Maybe

64type To = Maybe

66+makeWrapped ''PatchMapWithMove

67+

68+instance FunctorWithIndex k (PatchMapWithMove k)

69+instance FoldableWithIndex k (PatchMapWithMove k)

70+instance TraversableWithIndex k (PatchMapWithMove k) where

71+ itraverse = itraversed . Indexed

72+ itraversed = _Wrapped .> itraversed <. traversed

73+

77-- | Create a 'PatchMapWithMove', validating it

74-- | Create a 'PatchMapWithMove', validating it

78−patchMapWithMove

79− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)

75+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)

80patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

76patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

81 where valid = forwardLinks == backwardLinks

77 where valid = forwardLinks == backwardLinks

82 forwardLinks = Map.mapMaybe _nodeInfo_to m

78 forwardLinks = Map.mapMaybe _nodeInfo_to m

83− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->

79+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->

84− case _nodeInfo_from p of

80+ case _nodeInfo_from v of

85− From_Move from _ -> Just (from, to)

81+ From_Move from -> Just (from, to)

86 _ -> Nothing

82 _ -> Nothing

88-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'

84-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'

89−patchMapWithMoveInsertAll

85+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v

90− :: Map k (PatchTarget p) -> PatchMapWithMove k p

91patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo

86patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo

92 { _nodeInfo_from = From_Insert v

87 { _nodeInfo_from = From_Insert v

93 , _nodeInfo_to = Nothing

88 , _nodeInfo_to = Nothing

94 }

89 }

96−-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.

91+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.

97−insertMapKey

98− :: k -> PatchTarget p -> PatchMapWithMove k p

92+insertMapKey :: k -> v -> PatchMapWithMove k v

99insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

93insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

100

101−-- |Make a @'PatchMapWithMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:

95+-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:

102--

96--

103-- @

97-- @

104-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

98-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

105-- @

99-- @

106−moveMapKey

107− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p

100+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v

108moveMapKey src dst

101moveMapKey src dst

109 | src == dst = mempty

102 | src == dst = mempty

110 | otherwise =

103 | otherwise =

111 PatchMapWithMove $ Map.fromList

104 PatchMapWithMove $ Map.fromList

112− [ (dst, NodeInfo (From_Move src mempty) Nothing)

105+ [ (dst, NodeInfo (From_Move src) Nothing)

113 , (src, NodeInfo From_Delete (Just dst))

106 , (src, NodeInfo From_Delete (Just dst))

114 ]

107 ]

115

108

116−-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:

109+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

117--

110--

118-- @

111-- @

119-- let aMay = Map.lookup a map

112-- let aMay = Map.lookup a map

@@ -122,67 +115,53 @@ moveMapKey src dst

122-- . maybe id (Map.insert b) (aMay `mplus` bMay)

115-- . maybe id (Map.insert b) (aMay `mplus` bMay)

123-- . Map.delete a . Map.delete b $ map

116-- . Map.delete a . Map.delete b $ map

124-- @

117-- @

125−swapMapKey

126− :: (DecidablyEmpty p, Patch p)

127− => Ord k => k -> k -> PatchMapWithMove k p

118+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v

128swapMapKey src dst

119swapMapKey src dst

129 | src == dst = mempty

120 | src == dst = mempty

130 | otherwise =

121 | otherwise =

131 PatchMapWithMove $ Map.fromList

122 PatchMapWithMove $ Map.fromList

132− [ (dst, NodeInfo (From_Move src mempty) (Just src))

123+ [ (dst, NodeInfo (From_Move src) (Just src))

133− , (src, NodeInfo (From_Move dst mempty) (Just dst))

124+ , (src, NodeInfo (From_Move dst) (Just dst))

134 ]

125 ]

135

126

136−-- | Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in

127+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.

137−-- the mapping, equivalent to 'Map.delete'.

138−deleteMapKey

139− :: k -> PatchMapWithMove k v

128+deleteMapKey :: k -> PatchMapWithMove k v

140deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing

129deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing

141

130

142-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.

131-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.

143--

132--

144-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.

133-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.

145−unsafePatchMapWithMove

146− :: Map k (NodeInfo k p) -> PatchMapWithMove k p

134+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

147unsafePatchMapWithMove = PatchMapWithMove

135unsafePatchMapWithMove = PatchMapWithMove

148

136

149-- | Apply the insertions, deletions, and moves to a given 'Map'

137-- | Apply the insertions, deletions, and moves to a given 'Map'

150−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where

138+instance Ord k => Patch (PatchMapWithMove k v) where

151− type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)

139+ type PatchTarget (PatchMapWithMove k v) = Map k v

152− -- TODO: return Nothing sometimes

153− -- Note: the strict application here is critical to ensuring that incremental

140+ apply (PatchMapWithMove 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?

154− -- merges don't hold onto all their prerequisite events forever; can we make

155− -- this more robust?

156− apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)

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

141+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

158 From_Insert v -> Just v

142 From_Insert v -> Just v

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

143+ From_Move k -> Map.lookup k old

160 From_Delete -> Nothing

144 From_Delete -> Nothing

161− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of

145+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

162 From_Delete -> Just ()

146 From_Delete -> Just ()

163 _ -> Nothing

147 _ -> Nothing

164

148

165−-- | Returns all the new elements that will be added to the 'Map'

149+-- | Returns all the new elements that will be added to the 'Map'.

166−patchMapWithMoveNewElements

150+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

167− :: PatchMapWithMove k p -> [PatchTarget p]

168patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

151patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

169

152

170-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.

153-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.

171−patchMapWithMoveNewElementsMap

154+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

172− :: PatchMapWithMove k p -> Map k (PatchTarget p)

173patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

155patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

174 where f ni = case _nodeInfo_from ni of

156 where f ni = case _nodeInfo_from ni of

175 From_Insert v -> Just v

157 From_Insert v -> Just v

176− From_Move _ _ -> Nothing

158+ From_Move _ -> Nothing

177 From_Delete -> Nothing

159 From_Delete -> Nothing

178

160

179-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort

161-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort

180-- its values using the given ordering function. The set keys of the 'Map' is

162-- its values using the given ordering function. The set keys of the 'Map' is

181-- not changed.

163-- not changed.

182−patchThatSortsMapWith

164+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v

183− :: (Ord k, Monoid p)

184− => (PatchTarget p -> PatchTarget p -> Ordering)

185− -> Map k (PatchTarget p) -> PatchMapWithMove k p

186patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

165patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

187 where unsorted = Map.toList m

166 where unsorted = Map.toList m

188 sorted = sortBy (cmp `on` snd) unsorted

167 sorted = sortBy (cmp `on` snd) unsorted

@@ -190,25 +169,20 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW

190 Just (from, to)

169 Just (from, to)

191 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

170 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

192 g (to, _) (from, _) = if to == from then Nothing else

171 g (to, _) (from, _) = if to == from then Nothing else

193− let Just movingTo = Map.lookup from reverseMapping

172+ let Just movingTo = Map.lookup to reverseMapping

194− in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)

173+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)

195

174

196-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

175-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

197-- will produce a 'Map' with the same values as the second 'Map' but with the

176-- will produce a 'Map' with the same values as the second 'Map' but with the

198-- values sorted with the given ordering function.

177-- values sorted with the given ordering function.

199−patchThatChangesAndSortsMapWith

178+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

200− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)

201− => (PatchTarget p -> PatchTarget p -> Ordering)

202− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p

203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

179patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

204 where newList = Map.toList newByIndexUnsorted

180 where newList = Map.toList newByIndexUnsorted

205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

181 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

206

182

207-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

183-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

208-- will produce the second 'Map'.

184-- will produce the second 'Map'.

209−patchThatChangesMap

185+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v

210− :: (Ord k, Ord (PatchTarget p), Monoid p)

211− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p

212patchThatChangesMap oldByIndex newByIndex = patch

186patchThatChangesMap oldByIndex newByIndex = patch

213 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

187 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

214 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

188 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

@@ -223,15 +197,15 @@ patchThatChangesMap oldByIndex newByIndex = patch

223 if k `Set.member` fromKs

197 if k `Set.member` fromKs

224 then do

198 then do

225 putRemainingKeys $ Set.delete k fromKs

199 putRemainingKeys $ Set.delete k fromKs

226− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

200+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

227 else do

201 else do

228 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

202 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

229 putRemainingKeys remainingKeys

203 putRemainingKeys remainingKeys

230− return $ NodeInfo (From_Move fromK mempty) $ Just undefined

204+ return $ NodeInfo (From_Move fromK) $ Just undefined

231 Map.traverseWithKey f newByIndex

205 Map.traverseWithKey f newByIndex

232 unusedOldKeys = fold unusedValuesByValue

206 unusedOldKeys = fold unusedValuesByValue

233 pointlessMove k = \case

207 pointlessMove k = \case

234− From_Move k' _ | k == k' -> True

208+ From_Move k' | k == k' -> True

235 _ -> False

209 _ -> False

236 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

210 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

237 then Just undefined

211 then Just undefined

@@ -239,19 +213,16 @@ patchThatChangesMap oldByIndex newByIndex = patch

239 patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

213 patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

240

214

241-- | Change the 'From' value of a 'NodeInfo'

215-- | Change the 'From' value of a 'NodeInfo'

242−nodeInfoMapFrom

243− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

216+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

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

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

245

218

246-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

219-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

247-- 'Applicative', 'Monad', etc.) action to get the new value

220-- 'Applicative', 'Monad', etc.) action to get the new value

248−nodeInfoMapMFrom

249− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

221+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

250nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

222nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

251

223

252-- | Set the 'To' field of a 'NodeInfo'

224-- | Set the 'To' field of a 'NodeInfo'

253−nodeInfoSetTo

254− :: To k -> NodeInfo k v -> NodeInfo k v

225+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

255nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

226nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

256

227

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

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

@@ -260,24 +231,20 @@ data Fixup k v

260 | Fixup_Update (These (From k v) (To k))

231 | Fixup_Update (These (From k v) (To k))

261

232

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

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

263−instance ( Ord k

264− , Monoid p

265− , DecidablyEmpty p

266− , Patch p

267− ) => Semigroup (PatchMapWithMove k p) where

234+instance Ord k => Semigroup (PatchMapWithMove k v) where

268 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

235 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

269 where

236 where

270 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

237 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

271− h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]

238+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]

272 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

239 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

273− (Just toAfter, From_Move fromBefore p)

240+ (Just toAfter, From_Move fromBefore)

274− | fromBefore == toAfter && isNull p

241+ | fromBefore == toAfter

275 -> [(toAfter, Fixup_Delete)]

242 -> [(toAfter, Fixup_Delete)]

276 | otherwise

243 | otherwise

277 -> [ (toAfter, Fixup_Update (This editBefore))

244 -> [ (toAfter, Fixup_Update (This editBefore))

278 , (fromBefore, Fixup_Update (That mToAfter))

245 , (fromBefore, Fixup_Update (That mToAfter))

279 ]

246 ]

280− (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

247+ (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

281 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

248 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

282 (Nothing, _) -> []

249 (Nothing, _) -> []

283 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

250 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

@@ -295,13 +262,7 @@ instance ( Ord k

295 applyFixup _ ni = \case

262 applyFixup _ ni = \case

296 Fixup_Delete -> Nothing

263 Fixup_Delete -> Nothing

297 Fixup_Update u -> Just $ NodeInfo

264 Fixup_Update u -> Just $ NodeInfo

298− { _nodeInfo_from = case _nodeInfo_from ni of

265+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u

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

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

301− Just (From_Insert v) -> From_Insert $ applyAlways p' v

302− Just From_Delete -> From_Delete

303− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p

304− _ -> error "PatchMapWithMove: fixup for non-move From"

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

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

306 }

267 }

307 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

268 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

@@ -317,12 +278,7 @@ instance ( Ord k

317 That b -> Just b

278 That b -> Just b

318

279

319--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here

280--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here

320−-- | Compose patches having the same effect as applying the patches in turn:

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

321−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

322−instance ( Ord k

323− , Monoid p

324− , DecidablyEmpty p

325− , Patch p

326− ) => Monoid (PatchMapWithMove k p) where

282+instance Ord k => Monoid (PatchMapWithMove k v) where

327 mempty = PatchMapWithMove mempty

283 mempty = PatchMapWithMove mempty

328 mappend = (<>)

284 mappend = (<>)

src/Data/Patch/MapWithPatchingMove.hsnew file+328

@@ -0,0 +1,328 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE LambdaCase #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE PatternGuards #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

13+-- another

14+module Data.Patch.MapWithPatchingMove where

15+

16+import Data.Patch.Class

17+

18+import Control.Arrow

19+import Control.Monad.Trans.State

20+import Data.Foldable

21+import Data.Function

22+import Data.List

23+import Data.Map (Map)

24+import qualified Data.Map as Map

25+import Data.Maybe

26+--import Data.Proxy

27+#if !MIN_VERSION_base(4,9,0)

28+import Data.Semigroup (Semigroup (..), (<>))

29+#endif

30+import Data.Monoid.DecidablyEmpty

31+import qualified Data.Set as Set

32+import Data.These (These (..))

33+import Data.Tuple

34+

35+-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@

36+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,

37+-- and vice versa. There should never be any unpaired From/To keys.

38+newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove

39+ { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'

40+ unPatchMapWithPatchingMove :: Map k (NodeInfo k p)

41+ }

42+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)

43+deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)

44+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)

45+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)

46+

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

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

49+data NodeInfo k p = NodeInfo

50+ { _nodeInfo_from :: !(From k p)

51+ -- ^ Where do we get the new value for this key?

52+ , _nodeInfo_to :: !(To k)

53+ -- ^ If the old value is being kept (i.e. moved rather than deleted or

54+ -- replaced), where is it going?

55+ }

56+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)

57+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)

58+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)

59+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)

60+

61+-- | Describe how a key's new value should be produced

62+data From k p

63+ = From_Insert (PatchTarget p) -- ^ Insert the given value here

64+ | From_Delete -- ^ Delete the existing value, if any, from here

65+ | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch

66+

67+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)

68+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)

69+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)

70+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)

71+

72+-- | Describe where a key's old value will go. If this is 'Just', that means

73+-- the key's old value will be moved to the given other key; if it is 'Nothing',

74+-- that means it will be deleted.

75+type To = Maybe

76+

77+-- | Create a 'PatchMapWithPatchingMove', validating it

78+patchMapWithPatchingMove

79+ :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)

80+patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing

81+ where valid = forwardLinks == backwardLinks

82+ forwardLinks = Map.mapMaybe _nodeInfo_to m

83+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->

84+ case _nodeInfo_from p of

85+ From_Move from _ -> Just (from, to)

86+ _ -> Nothing

87+

88+-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'

89+patchMapWithPatchingMoveInsertAll

90+ :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

91+patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo

92+ { _nodeInfo_from = From_Insert v

93+ , _nodeInfo_to = Nothing

94+ }

95+

96+-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.

97+insertMapKey

98+ :: k -> PatchTarget p -> PatchMapWithPatchingMove k p

99+insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

100+

101+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:

102+--

103+-- @

104+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

105+-- @

106+moveMapKey

107+ :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p

108+moveMapKey src dst

109+ | src == dst = mempty

110+ | otherwise =

111+ PatchMapWithPatchingMove $ Map.fromList

112+ [ (dst, NodeInfo (From_Move src mempty) Nothing)

113+ , (src, NodeInfo From_Delete (Just dst))

114+ ]

115+

116+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:

117+--

118+-- @

119+-- let aMay = Map.lookup a map

120+-- bMay = Map.lookup b map

121+-- in maybe id (Map.insert a) (bMay `mplus` aMay)

122+-- . maybe id (Map.insert b) (aMay `mplus` bMay)

123+-- . Map.delete a . Map.delete b $ map

124+-- @

125+swapMapKey

126+ :: (DecidablyEmpty p, Patch p)

127+ => Ord k => k -> k -> PatchMapWithPatchingMove k p

128+swapMapKey src dst

129+ | src == dst = mempty

130+ | otherwise =

131+ PatchMapWithPatchingMove $ Map.fromList

132+ [ (dst, NodeInfo (From_Move src mempty) (Just src))

133+ , (src, NodeInfo (From_Move dst mempty) (Just dst))

134+ ]

135+

136+-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in

137+-- the mapping, equivalent to 'Map.delete'.

138+deleteMapKey

139+ :: k -> PatchMapWithPatchingMove k v

140+deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing

141+

142+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.

143+--

144+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.

145+unsafePatchMapWithPatchingMove

146+ :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p

147+unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove

148+

149+-- | Apply the insertions, deletions, and moves to a given 'Map'

150+instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where

151+ type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)

152+ -- TODO: return Nothing sometimes

153+ -- Note: the strict application here is critical to ensuring that incremental

154+ -- merges don't hold onto all their prerequisite events forever; can we make

155+ -- this more robust?

156+ apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)

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

158+ From_Insert v -> Just v

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

160+ From_Delete -> Nothing

161+ deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of

162+ From_Delete -> Just ()

163+ _ -> Nothing

164+

165+-- | Returns all the new elements that will be added to the 'Map'

166+patchMapWithPatchingMoveNewElements

167+ :: PatchMapWithPatchingMove k p -> [PatchTarget p]

168+patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap

169+

170+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.

171+patchMapWithPatchingMoveNewElementsMap

172+ :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)

173+patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p

174+ where f ni = case _nodeInfo_from ni of

175+ From_Insert v -> Just v

176+ From_Move _ _ -> Nothing

177+ From_Delete -> Nothing

178+

179+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort

180+-- its values using the given ordering function. The set keys of the 'Map' is

181+-- not changed.

182+patchThatSortsMapWith

183+ :: (Ord k, Monoid p)

184+ => (PatchTarget p -> PatchTarget p -> Ordering)

185+ -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

186+patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

187+ where unsorted = Map.toList m

188+ sorted = sortBy (cmp `on` snd) unsorted

189+ f (to, _) (from, _) = if to == from then Nothing else

190+ Just (from, to)

191+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

192+ g (to, _) (from, _) = if to == from then Nothing else

193+ let Just movingTo = Map.lookup from reverseMapping

194+ in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)

195+

196+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,

197+-- will produce a 'Map' with the same values as the second 'Map' but with the

198+-- values sorted with the given ordering function.

199+patchThatChangesAndSortsMapWith

200+ :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)

201+ => (PatchTarget p -> PatchTarget p -> Ordering)

202+ -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

203+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

204+ where newList = Map.toList newByIndexUnsorted

205+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

206+

207+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,

208+-- will produce the second 'Map'.

209+patchThatChangesMap

210+ :: (Ord k, Ord (PatchTarget p), Monoid p)

211+ => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

212+patchThatChangesMap oldByIndex newByIndex = patch

213+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

214+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

215+ let f k v = do

216+ remainingValues <- get

217+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

218+ then Map.delete v remainingValues

219+ else Map.insert v remainingKeys remainingValues

220+ case Map.lookup v remainingValues of

221+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take

222+ Just fromKs ->

223+ if k `Set.member` fromKs

224+ then do

225+ putRemainingKeys $ Set.delete k fromKs

226+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

227+ else do

228+ (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

229+ putRemainingKeys remainingKeys

230+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined

231+ Map.traverseWithKey f newByIndex

232+ unusedOldKeys = fold unusedValuesByValue

233+ pointlessMove k = \case

234+ From_Move k' _ | k == k' -> True

235+ _ -> False

236+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

237+ then Just undefined

238+ else Nothing

239+ patch = unsafePatchMapWithPatchingMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

240+

241+-- | Change the 'From' value of a 'NodeInfo'

242+nodeInfoMapFrom

243+ :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

244+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

245+

246+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

247+-- 'Applicative', 'Monad', etc.) action to get the new value

248+nodeInfoMapMFrom

249+ :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

250+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

251+

252+-- | Set the 'To' field of a 'NodeInfo'

253+nodeInfoSetTo

254+ :: To k -> NodeInfo k v -> NodeInfo k v

255+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

256+

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

258+data Fixup k v

259+ = Fixup_Delete

260+ | Fixup_Update (These (From k v) (To k))

261+

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

263+instance ( Ord k

264+ , Monoid p

265+ , DecidablyEmpty p

266+ , Patch p

267+ ) => Semigroup (PatchMapWithPatchingMove k p) where

268+ PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m

269+ where

270+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

271+ h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]

272+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

273+ (Just toAfter, From_Move fromBefore p)

274+ | fromBefore == toAfter && isNull p

275+ -> [(toAfter, Fixup_Delete)]

276+ | otherwise

277+ -> [ (toAfter, Fixup_Update (This editBefore))

278+ , (fromBefore, Fixup_Update (That mToAfter))

279+ ]

280+ (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

281+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

282+ (Nothing, _) -> []

283+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

284+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)

285+ | This x <- a, That y <- b

286+ = Fixup_Update $ These x y

287+ | That y <- a, This x <- b

288+ = Fixup_Update $ These x y

289+ mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"

290+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections

291+ combineNodeInfos _ nia nib = NodeInfo

292+ { _nodeInfo_from = _nodeInfo_from nia

293+ , _nodeInfo_to = _nodeInfo_to nib

294+ }

295+ applyFixup _ ni = \case

296+ Fixup_Delete -> Nothing

297+ Fixup_Update u -> Just $ NodeInfo

298+ { _nodeInfo_from = case _nodeInfo_from ni of

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

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

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

302+ Just From_Delete -> From_Delete

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

304+ _ -> error "PatchMapWithPatchingMove: fixup for non-move From"

305+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

306+ }

307+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

308+ getHere :: These a b -> Maybe a

309+ getHere = \case

310+ This a -> Just a

311+ These a _ -> Just a

312+ That _ -> Nothing

313+ getThere :: These a b -> Maybe b

314+ getThere = \case

315+ This _ -> Nothing

316+ These _ b -> Just b

317+ That b -> Just b

318+

319+--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here

320+-- | Compose patches having the same effect as applying the patches in turn:

321+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

322+instance ( Ord k

323+ , Monoid p

324+ , DecidablyEmpty p

325+ , Patch p

326+ ) => Monoid (PatchMapWithPatchingMove k p) where

327+ mempty = PatchMapWithPatchingMove mempty

328+ mappend = (<>)