develop...584334f · patch

git.iko.soy/patch

develop and 584334f have 2 merge bases. This is what 584334f changed since the first, cb657ca, as git diff develop...584334f shows it.

ChangeLog.md+14

since splitsnapshots

unifiedsplit

@@ -4,6 +4,20 @@

5* `PatchMapWithMove` supports moves with a patch.

7+* `PatchDMapWithMove` supports moves with a patch.

9+## 0.0.2.0

10+

11+* Consistently provide:

12+

13+ - `Wrapped` instances

14+

15+ - `*WithIndex` instances

16+

17+ - `un*` newtype unwrappers

18+

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

20+

7## 0.0.1.0

21## 0.0.1.0

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

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

dep/reflex-platform/default.nix+7−6

@@ -1,7 +1,8 @@

1# DO NOT HAND-EDIT THIS FILE

2+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:

3+ if !fetchSubmodules && !private then builtins.fetchTarball {

4+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;

2−import ((import <nixpkgs> {}).fetchFromGitHub (

5+ } else (import <nixpkgs> {}).fetchFromGitHub {

6+ inherit owner repo rev sha256 fetchSubmodules private;

7+ };

3− let json = builtins.fromJSON (builtins.readFile ./github.json);

8+in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))

4− in { inherit (json) owner repo rev sha256;

5− private = json.private or false;

6− }

7−))

dep/reflex-platform/github.json+3−2

@@ -2,6 +2,7 @@

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4 "branch": "master",

5− "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",

5+ "private": false,

6− "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"

6+ "rev": "c9d11db1b98855fe8ab24a3ff6a5dbe0ad902ad9",

7+ "sha256": "0sfzkqdvyah5mwvmli0wq1nl0b8cvk2cmfgfy4rz57wv42x3099y"

patch.cabal+6−2

@@ -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,16 +35,19 @@ 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

43+ exposed-modules: Control.Category.DecidablyEmpty

42− exposed-modules: Data.Functor.Misc

44+ , Data.Functor.Misc

43 , Data.Monoid.DecidablyEmpty

45 , Data.Monoid.DecidablyEmpty

44 , Data.Patch

46 , Data.Patch

45 , Data.Patch.Class

47 , Data.Patch.Class

46 , Data.Patch.DMap

48 , Data.Patch.DMap

47 , Data.Patch.DMapWithMove

49 , Data.Patch.DMapWithMove

50+ , Data.Patch.DMapWithMove.By

48 , Data.Patch.IntMap

51 , Data.Patch.IntMap

49 , Data.Patch.Map

52 , Data.Patch.Map

50 , Data.Patch.MapWithMove

53 , Data.Patch.MapWithMove

@@ -53,6 +56,7 @@ library

54 if flag(split-these)

57 if flag(split-these)

55 build-depends: these >= 1 && <1.1

58 build-depends: these >= 1 && <1.1

59+ , these-lens >= 1 && <1.1

56 , semialign >=1 && <1.2

60 , semialign >=1 && <1.2

57 , monoidal-containers >= 0.6 && < 0.7

61 , monoidal-containers >= 0.6 && < 0.7

58 else

62 else

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/Control/Category/DecidablyEmpty.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# LANGUAGE TypeOperators #-}

2+-- TODO upstream somwhere else?

3+module Control.Category.DecidablyEmpty where

5+import Control.Category

6+import Data.Type.Equality

8+class Category c => DecidablyEmpty c where

9+ isId :: c a b -> Maybe (a :~: b)

src/Data/Functor/Misc.hs+28−5

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE DeriveTraversable #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

@@ -17,6 +17,8 @@

17module Data.Functor.Misc

18 ( -- * Const2

19 Const2 (..)

20+ , Proxy3 (..)

21+ , First2 (..)

20 , unConst2

22 , unConst2

21 , dmapToMap

23 , dmapToMap

22 , dmapToIntMap

24 , dmapToIntMap

@@ -37,6 +39,7 @@ module Data.Functor.Misc

37 , ComposeMaybe (..)

39 , ComposeMaybe (..)

38 ) where

40 ) where

42+import qualified Control.Category as Cat

40import Control.Applicative ((<$>))

43import Control.Applicative ((<$>))

41import Data.Dependent.Map (DMap)

44import Data.Dependent.Map (DMap)

42import qualified Data.Dependent.Map as DMap

45import qualified Data.Dependent.Map as DMap

@@ -48,6 +51,7 @@ import Data.IntMap (IntMap)

48import qualified Data.IntMap as IntMap

51import qualified Data.IntMap as IntMap

49import Data.Map (Map)

52import Data.Map (Map)

50import qualified Data.Map as Map

53import qualified Data.Map as Map

54+import qualified Data.Semigroupoid as Cat

51import Data.Some (Some(Some))

55import Data.Some (Some(Some))

52import Data.These

56import Data.These

53import Data.Type.Equality ((:~:)(Refl))

57import Data.Type.Equality ((:~:)(Refl))

@@ -63,15 +67,15 @@ data Const2 :: * -> x -> x -> * where

63 Const2 :: k -> Const2 k v v

67 Const2 :: k -> Const2 k v v

64 deriving (Typeable)

68 deriving (Typeable)

66−-- | Extract the value from a Const2

67−unConst2 :: Const2 k v v' -> k

68−unConst2 (Const2 k) = k

69−

70deriving instance Eq k => Eq (Const2 k v v')

71deriving instance Ord k => Ord (Const2 k v v')

72deriving instance Show k => Show (Const2 k v v')

73deriving instance Read k => Read (Const2 k v v)

75+-- | Extract the value from a Const2

76+unConst2 :: Const2 k v v' -> k

77+unConst2 (Const2 k) = k

78+

75instance Show k => GShow (Const2 k v) where

79instance Show k => GShow (Const2 k v) where

76 gshowsPrec n x@(Const2 _) = showsPrec n x

80 gshowsPrec n x@(Const2 _) = showsPrec n x

@@ -87,6 +91,25 @@ instance Ord k => GCompare (Const2 k v) where

87 EQ -> GEQ

91 EQ -> GEQ

88 GT -> GGT

92 GT -> GGT

94+data Proxy3 :: x -> y -> z -> * where

95+ Proxy3 :: Proxy3 vx vy vz

96+ deriving ( Show, Read, Eq, Ord

97+ , Functor, Foldable, Traversable

98+ , Typeable

99+ )

100+

101+instance Cat.Category (Proxy3 x) where

102+ id = Proxy3

103+ ~Proxy3 . ~Proxy3 = Proxy3

104+

105+newtype First2 (t :: k -> *) (a :: k) (b :: k) = First2 (t b)

106+ deriving ( Show, Read, Eq, Ord

107+ , Functor, Foldable, Traversable

108+ )

109+

110+instance Cat.Semigroupoid (First2 x) where

111+ First2 x `o` ~(First2 _) = First2 x

112+

90-- | Convert a 'DMap' to a regular 'Map'

113-- | Convert a 'DMap' to a regular 'Map'

91dmapToMap :: DMap (Const2 k v) Identity -> Map k v

114dmapToMap :: DMap (Const2 k v) Identity -> Map k v

92dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

115dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

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+132−6

@@ -1,18 +1,53 @@

1+{-# LANGUAGE DefaultSignatures #-}

2+{-# LANGUAGE DerivingStrategies #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE PolyKinds #-}

1{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeOperators #-}

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

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

3module Data.Patch.Class where

10module Data.Patch.Class where

12+import qualified Data.Semigroupoid as Cat

5import Data.Functor.Identity

13import Data.Functor.Identity

14+import Data.Functor.Misc

6import Data.Maybe

15import Data.Maybe

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

16import Data.Semigroup (Semigroup(..))

8import Data.Proxy

17import Data.Proxy

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

19+

20+class PatchHet p where

21+ type PatchSource p :: *

22+ type PatchTarget p :: *

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

24+ -- 'Nothing'.

25+ applyHet

26+ :: p

27+ -> PatchSource p

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

29+ default applyHet

30+ :: Patch p

31+ => p

32+ -> PatchSource p

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

34+ applyHet p a = case apply p a of

35+ Nothing -> Left Refl

36+ Just a' -> Right a'

37+

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

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

40+applyAlwaysHet p t = case applyHet p t of

41+ Left Refl -> t

42+ Right t' -> t'

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

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

11--

45--

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

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

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

48+class ( PatchHet p

49+ , PatchSource p ~ PatchTarget p

14−class Patch p where

50+ ) => Patch p where

15− type PatchTarget p :: *

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

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

17 -- 'Nothing'.

52 -- 'Nothing'.

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

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

@@ -22,19 +57,110 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p

22applyAlways p t = fromMaybe t $ apply p t

57applyAlways p t = fromMaybe t $ apply p t

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

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

25−instance Patch (Identity a) where

60+instance PatchHet (Identity a) where

61+ type PatchSource (Identity a) = a

26 type PatchTarget (Identity a) = a

62 type PatchTarget (Identity a) = a

63+instance Patch (Identity a) where

27 apply (Identity a) _ = Just a

64 apply (Identity a) _ = Just a

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

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

30−instance Patch (Proxy a) where

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

68+ type PatchSource (Proxy a) = a

31 type PatchTarget (Proxy a) = a

69 type PatchTarget (Proxy a) = a

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

32 apply ~Proxy _ = Nothing

71 apply ~Proxy _ = Nothing

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

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

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

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

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

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

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

76+composePatchFunctions

77+ :: (Patch p, Semigroup p)

78+ => (PatchTarget p -> p)

79+ -> (PatchTarget p -> p)

80+ -> PatchTarget p -> p

38composePatchFunctions g f a =

81composePatchFunctions g f a =

39 let fp = f a

82 let fp = f a

40 in g (applyAlways fp a) <> fp

83 in g (applyAlways fp a) <> fp

84+

85+

86+class PatchHet2Base (p :: k -> k -> *) where

87+ type PatchSource1 p :: k -> *

88+ type PatchTarget1 p :: k -> *

89+

90+class ( PatchHet2Base p

91+ , PatchHet (p from to)

92+ , PatchSource1 p from ~ PatchSource (p from to)

93+ , PatchTarget1 p to ~ PatchTarget (p from to)

94+ ) => PatchHet2Locally (p :: k -> k -> *) from to where

95+instance ( PatchHet2Base p

96+ , PatchHet (p from to)

97+ , PatchSource1 p from ~ PatchSource (p from to)

98+ , PatchTarget1 p to ~ PatchTarget (p from to)

99+ ) => PatchHet2Locally (p :: k -> k -> *) from to where

100+

101+applyHet2Locally

102+ :: PatchHet2Locally p from to

103+ => p from to

104+ -> PatchSource1 p from

105+ -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)

106+applyHet2Locally = applyHet

107+

108+applyAlwaysHet2Locally

109+ :: PatchHet2Locally p from to

110+ => p from to

111+ -> PatchSource1 p from

112+ -> PatchTarget1 p to

113+applyAlwaysHet2Locally = applyAlwaysHet

114+

115+-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and

116+-- PatchHet2Locally, or at least get rid of this.

117+class PatchHet2Base p => PatchHet2 (p :: k -> k -> *) where

118+ applyHet2

119+ :: p from to

120+ -> PatchSource1 p from

121+ -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)

122+

123+applyAlwaysHet2

124+ :: PatchHet2 p

125+ => p from to

126+ -> PatchSource1 p from

127+ -> PatchTarget1 p to

128+applyAlwaysHet2 p t = case applyHet2 p t of

129+ Left Refl -> t

130+ Right t' -> t'

131+

132+-- | Connect the classes without quanitified constraints

133+newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }

134+ deriving newtype Cat.Semigroupoid

135+

136+instance PatchHet2 p => PatchHet (ProjectLocal p from to) where

137+ type PatchSource (ProjectLocal p from to) = PatchSource1 p from

138+ type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to

139+ applyHet (ProjectLocal p) = applyHet2 p

140+

141+instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where

142+ type PatchSource1 (ProjectLocal p) = PatchSource1 p

143+ type PatchTarget1 (ProjectLocal p) = PatchTarget1 p

144+

145+class ( PatchHet2Base p

146+ , PatchSource1 p ~ PatchTarget1 p

147+ ) => Patch2 p

148+instance ( PatchHet2Base p

149+ , PatchSource1 p ~ PatchTarget1 p

150+ ) => Patch2 p

151+

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

153+instance PatchHet (First2 (t :: k -> *) (from :: k) (to :: k)) where

154+ type PatchSource (First2 t from to) = t from

155+ type PatchTarget (First2 t from to) = t to

156+ applyHet (First2 val) _ = Right val

157+

158+-- | 'Proxy3' can be used as a 'Patch' that always does nothing

159+instance PatchHet (Proxy3 (t :: k -> *) (a :: k) (a :: k)) where

160+ type PatchSource (Proxy3 t a a) = t a

161+ type PatchTarget (Proxy3 t a a) = t a

162+ applyHet ~Proxy3 _ = Left Refl

163+

164+instance PatchHet2Base (Proxy3 (t :: k -> *) :: k -> k -> *) where

165+ type PatchSource1 (Proxy3 t) = t

166+ type PatchTarget1 (Proxy3 t) = t

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+405−152

@@ -1,101 +1,222 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE InstanceSigs #-}

5{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE PatternGuards #-}

9{-# LANGUAGE PatternGuards #-}

8{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE Rank2Types #-}

11{-# LANGUAGE Rank2Types #-}

10{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE StandaloneDeriving #-}

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.

16module Data.Patch.DMapWithMove where

20module Data.Patch.DMapWithMove where

18−import Data.Patch.Class

22+import qualified Control.Category as Cat

19−import Data.Patch.MapWithMove (PatchMapWithMove (..))

23+--import qualified Control.Category.DecidablyEmpty as Cat

20−import qualified Data.Patch.MapWithMove as MapWithMove

21−

22−import Data.Constraint.Extras

24+import Data.Constraint.Extras (Has')

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

25+import Data.Dependent.Map (DMap)

26+import Data.Dependent.Sum (DSum (..))

24import qualified Data.Dependent.Map as DMap

27import qualified Data.Dependent.Map as DMap

25−import Data.Functor.Constant

28+import Data.Functor.Constant (Constant (..))

26import Data.Functor.Misc

29import Data.Functor.Misc

30+ ( Const2 (..), Proxy3 (..)

31+ , weakenDMapWith

32+ , dmapToMapWith

33+ )

27−import Data.Functor.Product

34+import Data.Functor.Product (Product (..))

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

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

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

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

30import qualified Data.Map as Map

37import qualified Data.Map as Map

31import Data.Maybe

38import Data.Maybe

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

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

40+import Data.Semigroupoid as Cat

33import Data.Some (Some(Some))

41import Data.Some (Some(Some))

34−import Data.Proxy

42+import Data.Proxy (Proxy (..))

35−import Data.These

43+import Data.These (These (..))

45+import Data.Patch.Class

46+ ( Patch (..), PatchHet (..)

47+ , PatchHet2 (..), PatchSource1, PatchTarget1

48+ , applyAlwaysHet2

49+ )

50+import Data.Patch.MapWithMove (PatchMapWithMove (..))

51+import qualified Data.Patch.MapWithMove as MapWithMove

52+

53+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo'

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

54+-- which describes how it will be changed by the patch and connects move sources

38−-- destinations.

55+-- and destinations.

39--

56--

40-- Invariants:

57-- Invariants:

41--

58--

42−-- * A key should not move to itself.

59+-- * A key should not move to itself.

60+--

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

61+-- * A move should always be represented with both the destination key (as a

62+-- 'From_Move') and the source key (as a @'ComposeMaybe' ('Just'

63+-- destination)@)

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

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

66+--deriving instance ( GShow k

67+-- , HasZip Show k p

68+-- , Has' Show k (PatchTarget1 p)

69+-- ) => Show (PatchDMapWithMove k p)

70+--deriving instance ( GRead k

71+-- , HasZip Read k p

72+-- , Has' Read k (PatchTarget1 p)

73+-- ) => Read (PatchDMapWithMove k p)

74+--deriving instance ( GEq k

75+-- , HasZip Eq k p

76+-- , Has' Eq k (PatchTarget1 p)

77+-- ) => Eq (PatchDMapWithMove k p)

78+--deriving instance ( GCompare k

79+-- , HasZip Ord k p

80+-- , Has' Ord k (PatchTarget1 p)

81+-- ) => Ord (PatchDMapWithMove k p)

82+

83+-- | Structure which represents what changes apply to a particular key.

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

84+-- @_nodeInfo_from@ specifies what happens to this key, and in particular what

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

85+-- other key the current key is moving from, while @_nodeInfo_to@ specifies what

86+-- key the current key is moving to if involved in a move.

48−data NodeInfo k v a = NodeInfo

87+data NodeInfo k p a = NodeInfo

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

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

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

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

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

90+ , _nodeInfo_to :: !(To k p a)

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

91+ -- ^ Where this key is moving to, if involved in a move. Should only be

92+ -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.

53 }

93 }

94+

54− deriving (Show)

95+--deriving instance ( Show (k a)

55−

96+-- , Show (p a a)

97+-- , Show (PatchTarget1 p a)

98+-- ) => Show (NodeInfo k p a)

99+--deriving instance ( Read (k a)

100+-- , Read (p a a)

101+-- , Read (PatchTarget1 p a)

102+-- ) => Read (NodeInfo k p a)

103+--deriving instance ( Eq (k a)

104+-- , Eq (p a a)

105+-- , Eq (PatchTarget1 p a)

106+-- ) => Eq (NodeInfo k p a)

107+--deriving instance ( Ord (k a)

108+-- , Ord (p a a)

109+-- , Ord (PatchTarget1 p a)

110+-- ) => Ord (NodeInfo k p a)

111+

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

112+-- | Structure describing a particular change to a key, be it inserting a new

113+-- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting

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

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

115+--

116+-- This type isn't used directly as the from field patch, but is instead wrapped

117+-- in an existential. However, it is nice to be able to reason about this in

118+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.

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

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

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

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

121+ -- p a@

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

122+ From_Insert :: PatchTarget1 p to -> From k p to

61− -- |Delete the existing key

123+ -- | Delete the existing key

62− From_Delete :: From k v a

124+ From_Delete :: From k p to

125+ -- | Move the value from the given key @k a@ to this key. The source key

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

126+ -- should also have an entry in the patch giving the current key as

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

127+ -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.

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

128+ From_Move :: !(DSum k (Flip p to)) -> From k p to

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

129+

67−

130+deriving instance ( Show (k a), GShow k

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

131+ , Has' Show k (Flip p a)

69−-- operation.

132+ , Show (PatchTarget1 p a)

70−type To = ComposeMaybe

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

134+deriving instance ( Read (k a), GRead k

135+ , Has' Read k (Flip p a)

136+ , Read (PatchTarget1 p a)

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

138+deriving instance ( GEq k

139+ , Has' Eq k (Flip p a)

140+ , Eq (PatchTarget1 p a)

141+ ) => Eq (From k p a)

142+deriving instance ( GCompare k

143+ , Has' Eq k (Flip p a) -- superclass bug

144+ , Has' Ord k (Flip p a)

145+ , Ord (PatchTarget1 p a)

146+ ) => Ord (From k p a)

147+

148+newtype Flip p to from = Flip (p from to)

149+

150+instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where

151+ id = Flip Cat.id

152+ Flip y . Flip x = Flip $ x Cat.. y

153+

154+-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@

155+-- is, we store just the information necessary to compose a @To@ and @From@ like

156+-- @oLocal@ composes two @From@s.

157+data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where

158+ -- | Delete or leave in place

159+ To_NonMove :: To k p from

160+ -- | Move the value from the given key @k a@ to this key. The target key

161+ -- should also have an entry in the patch giving the current key in

162+ -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.

163+ To_Move :: !(DSum k (p from)) -> To k p from

164+

165+deriving instance ( Show (k a), GShow k

166+ , Has' Show k (p a)

167+ , Show (PatchTarget1 p a)

168+ ) => Show (To k p a)

169+deriving instance ( Read (k a), GRead k

170+ , Has' Read k (p a)

171+ , Read (PatchTarget1 p a)

172+ ) => Read (To k p a)

173+deriving instance ( GEq k

174+ , Has' Eq k (p a)

175+ , Eq (PatchTarget1 p a)

176+ ) => Eq (To k p a)

177+deriving instance ( GCompare k

178+ , Has' Eq k (p a) -- superclass bug

179+ , Has' Ord k (p a)

180+ , Ord (PatchTarget1 p a)

181+ ) => Ord (To k p a)

182

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

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

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

184+validPatchDMapWithMove

185+ :: forall k v

186+ . (GCompare k, GShow k)

187+ => DMap k (NodeInfo k v)

188+ -> Bool

74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

189validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

190

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

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

192+validationErrorsForPatchDMapWithMove

193+ :: forall k v

194+ . (GCompare k, GShow k)

195+ => DMap k (NodeInfo k v)

196+ -> [String]

78validationErrorsForPatchDMapWithMove m =

197validationErrorsForPatchDMapWithMove m =

79 noSelfMoves <> movesBalanced

198 noSelfMoves <> movesBalanced

80 where

199 where

81 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

200 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

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

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

203+ selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))

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

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

84 selfMove _ = Nothing

205 selfMove _ = Nothing

85 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

206 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

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

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

87 case DMap.lookup src m of

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

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

210+ Just (NodeInfo _ (To_Move (dst' :=> _))) ->

90 if isNothing (dst' `geq` dst)

211 if isNothing (dst' `geq` dst)

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

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

92 else Nothing

213 else Nothing

93 _ ->

214 _ ->

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

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

216+ unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =

96 case DMap.lookup dst m of

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

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

219+ Just (NodeInfo (From_Move (src' :=> _)) _) ->

99 if isNothing (src' `geq` src)

220 if isNothing (src' `geq` src)

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

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

101 else Nothing

222 else Nothing

@@ -104,35 +225,49 @@ validationErrorsForPatchDMapWithMove m =

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

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

105 unbalancedMove _ = Nothing

226 unbalancedMove _ = Nothing

106

227

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

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

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

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

113

230

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

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

115−data Fixup k v a

232+data Fixup k p a

116 = Fixup_Delete

233 = Fixup_Delete

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

234+ | Fixup_Update (These (From k p a) (To k p a))

118−

235+

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

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

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

238+instance ( GCompare k

239+ , Cat.Semigroupoid p

240+ -- , Cat.DecidablyEmpty p

241+ , PatchHet2 p

242+ , PatchSource1 p ~ PatchTarget1 p

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

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

121 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

244 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

122 where

245 where

246+ connections :: [DSum k (Pair1 (To k p) (From k p))]

247+ connections = DMap.toList $ DMap.intersectionWithKey

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

248+ (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))

249+ ma

250+ mb

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

251+ h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]

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

252+ h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of

126− (Just toAfter, From_Move fromBefore)

253+ (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->

127− | isJust $ fromBefore `geq` toAfter

254+ --case toAfter `geq` fromBefore of

255+ -- Just Refl | Just Refl <- Cat.isId p0 ->

128− -> [toAfter :=> Fixup_Delete]

256+ -- [ toAfter :=> Fixup_Delete ]

129− | otherwise

257+ -- _ ->

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

258+ [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))

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

259+ , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))

132− ]

260+ ]

261+ (To_NonMove, From_Move (fromBefore :=> _)) ->

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

262+ -- The item is destroyed in the second patch, so indicate that it is

263+ -- destroyed in the source map

264+ [fromBefore :=> Fixup_Update (That To_NonMove)]

265+ (To_Move (toAfter :=> p), From_Insert val) ->

266+ [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]

267+ (To_Move (toAfter :=> _), From_Delete) ->

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

268+ [toAfter :=> Fixup_Update (This From_Delete)]

135− (Nothing, _) -> []

269+ (To_NonMove, _) ->

270+ []

136 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

271 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

137 mergeFixups _ (Fixup_Update a) (Fixup_Update b)

272 mergeFixups _ (Fixup_Update a) (Fixup_Update b)

138 | This x <- a, That y <- b

273 | This x <- a, That y <- b

@@ -163,13 +298,19 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where

163 These _ b -> Just b

298 These _ b -> Just b

164 That b -> Just b

299 That b -> Just b

165

300

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

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

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

303+instance ( GCompare k

304+ , Cat.Semigroupoid p

305+ -- , DecidablyEmpty p

306+ , PatchHet2 p

307+ , PatchSource1 p ~ PatchTarget1 p

167−instance GCompare k => Monoid (PatchDMapWithMove k v) where

308+ ) => Monoid (PatchDMapWithMove k p) where

168 mempty = PatchDMapWithMove mempty

309 mempty = PatchDMapWithMove mempty

169 mappend = (<>)

310 mappend = (<>)

170

311

171{-

312{-

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

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

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

174 where

315 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

316 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,25 +331,31 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith

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

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

191-}

332-}

192

333

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

334+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or

335+-- updating a value @PatchTarget1 p a@ to the given key @k a@, like

336+-- 'DMap.insert'.

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

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

195insertDMapKey k v =

338insertDMapKey k v =

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

339+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove

197

340

198−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:

341+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value

342+-- from the first key @k a@ to the second key @k a@, equivalent to:

199--

343--

200-- @

344-- @

201-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))

345-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))

202-- @

346-- @

347+moveDMapKey

348+ :: GCompare k

203−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

349+ => k a -> k a -> PatchDMapWithMove k (Proxy3 v)

204moveDMapKey src dst = case src `geq` dst of

350moveDMapKey src dst = case src `geq` dst of

205 Nothing -> PatchDMapWithMove $ DMap.fromList

351 Nothing -> PatchDMapWithMove $ DMap.fromList

206− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)

352+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove

207− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)

353+ , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)

208 ]

354 ]

209− Just _ -> mempty

355+ Just _ -> PatchDMapWithMove DMap.empty

210

356

211−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

357+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys

358+-- in the mapping, equivalent to:

212--

359--

213-- @

360-- @

214-- let aMay = DMap.lookup a dmap

361-- let aMay = DMap.lookup a dmap

@@ -217,17 +364,18 @@ moveDMapKey src dst = case src `geq` dst of

217-- . maybe id (DMap.insert b) (aMay `mplus` bMay)

364-- . maybe id (DMap.insert b) (aMay `mplus` bMay)

218-- . DMap.delete a . DMap.delete b $ dmap

365-- . DMap.delete a . DMap.delete b $ dmap

219-- @

366-- @

220−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

367+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)

221swapDMapKey src dst = case src `geq` dst of

368swapDMapKey src dst = case src `geq` dst of

222 Nothing -> PatchDMapWithMove $ DMap.fromList

369 Nothing -> PatchDMapWithMove $ DMap.fromList

223− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)

370+ [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)

224− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)

371+ , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)

225 ]

372 ]

226− Just _ -> mempty

373+ Just _ -> PatchDMapWithMove DMap.empty

227

374

228−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.

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

376+-- the mapping, equivalent to 'DMap.delete'.

229deleteDMapKey :: k a -> PatchDMapWithMove k v

377deleteDMapKey :: k a -> PatchDMapWithMove k v

230−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing

378+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove

231

379

232{-

380{-

233k1, k2 :: Const2 Int () ()

381k1, k2 :: Const2 Int () ()

@@ -253,17 +401,20 @@ dst (PatchDMapWithMove x _) = x

253src (PatchDMapWithMove _ x) = x

401src (PatchDMapWithMove _ x) = x

254-}

402-}

255

403

256−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.

404+-- | Extract the 'DMap' representing the patch changes from the

405+-- 'PatchDMapWithMove'.

257unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

406unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

258unPatchDMapWithMove (PatchDMapWithMove p) = p

407unPatchDMapWithMove (PatchDMapWithMove p) = p

259

408

260−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.

409+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',

410+-- without checking any invariants.

261--

411--

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

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

263unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

413unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

264unsafePatchDMapWithMove = PatchDMapWithMove

414unsafePatchDMapWithMove = PatchDMapWithMove

265

415

416+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while

266−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned

417+-- checking invariants. If the invariants are satisfied, @Right p@ is returned

267-- otherwise @Left errors@.

418-- otherwise @Left errors@.

268patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)

419patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)

269patchDMapWithMove dm =

420patchDMapWithMove dm =

@@ -271,94 +422,196 @@ patchDMapWithMove dm =

271 [] -> Right $ unsafePatchDMapWithMove dm

422 [] -> Right $ unsafePatchDMapWithMove dm

272 errs -> Left errs

423 errs -> Left errs

273

424

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

425+-- | Map a natural transform @v -> v'@ over the given patch, transforming

426+-- @'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'

427+mapPatchDMapWithMove

428+ :: forall k p p'

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

430+ -> (forall from to. p from to -> p' from to)

431+ -> PatchDMapWithMove k p

432+ -> PatchDMapWithMove k p'

276−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

433+mapPatchDMapWithMove f g (PatchDMapWithMove m) =

434+ PatchDMapWithMove $ DMap.map (\ni -> NodeInfo

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

435+ { _nodeInfo_from = h $ _nodeInfo_from ni

436+ , _nodeInfo_to = j $ _nodeInfo_to ni

437+ }) m

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

438+ where h :: forall a. From k p a -> From k p' a

279− g = \case

439+ h = \case

280 From_Insert v -> From_Insert $ f v

440 From_Insert v -> From_Insert $ f v

281 From_Delete -> From_Delete

441 From_Delete -> From_Delete

282− From_Move k -> From_Move k

442+ From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)

283−

443+ j :: forall a. To k p a -> To k p' a

444+ j = \case

445+ To_NonMove -> To_NonMove

446+ To_Move (k :=> p) -> To_Move $ k :=> g p

447+

448+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@

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

449+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m

450+-- ('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')

451+traversePatchDMapWithMove

452+ :: forall m k p p'

453+ . Applicative m

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

455+ -> (forall from to. p from to -> m (p' from to))

456+ -> PatchDMapWithMove k p

457+ -> m (PatchDMapWithMove k p')

286−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

458+traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey

287−

459+ (\_ -> f)

460+ (\_ _ -> g)

461+

462+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@

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

463+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m

464+-- ('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')

465+traversePatchDMapWithMoveWithKey

466+ :: forall m k p p'

467+ . Applicative m

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

469+ -> (forall from to. k from -> k to -> p from to -> m (p' from to))

470+ -> PatchDMapWithMove k p

471+ -> m (PatchDMapWithMove k p')

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

472+traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =

473+ PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo

474+ <$> h k (_nodeInfo_from ni)

475+ <*> j k (_nodeInfo_to ni)) m

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

476+ where h :: forall a. k a -> From k p a -> m (From k p' a)

292− g k = \case

477+ h k = \case

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

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

294 From_Delete -> pure From_Delete

479 From_Delete -> pure From_Delete

295− From_Move fromKey -> pure $ From_Move fromKey

480+ From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p

296−

481+ j :: forall a. k a -> To k p a -> m (To k p' a)

482+ j k = \case

483+ To_NonMove -> pure To_NonMove

484+ To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p

485+

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

486+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k

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

488+nodeInfoMapFrom

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

490+ -> (To k p a -> To k p' a)

491+ -> NodeInfo k p a

492+ -> NodeInfo k p' a

493+nodeInfoMapFrom f g ni = NodeInfo

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

494+ { _nodeInfo_from = f $ _nodeInfo_from ni

300−

495+ , _nodeInfo_to = g $ _nodeInfo_to ni

496+ }

497+

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

498+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into

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

500+nodeInfoMapFromM

501+ :: Applicative f

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

503+ -> (To k p a -> f (To k p' a))

504+ -> NodeInfo k p a

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

506+nodeInfoMapFromM f g ni = NodeInfo

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

507+ <$> f (_nodeInfo_from ni)

304−

508+ <*> g (_nodeInfo_to ni)

509+

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

510+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys

511+-- from @k a@ to @'Some' k@ and applying a given weakening function

306−-- values.

512+-- @PatchTarget1 p a -> v'@ to values.

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

513+weakenPatchDMapWithMoveWith

514+ :: forall k p p'

515+ . (forall a. PatchTarget1 p a -> PatchTarget p')

516+ -> (forall from to. p from to -> p')

517+ -> PatchDMapWithMove k p

518+ -> PatchMapWithMove (Some k) p'

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

519+weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =

520+ PatchMapWithMove $ weakenDMapWith h m

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

521+ where h :: forall a. NodeInfo k p a -> MapWithMove.NodeInfo (Some k) p'

310− g ni = MapWithMove.NodeInfo

522+ h ni = MapWithMove.NodeInfo

311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

523 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

312 From_Insert v -> MapWithMove.From_Insert $ f v

524 From_Insert v -> MapWithMove.From_Insert $ f v

313 From_Delete -> MapWithMove.From_Delete

525 From_Delete -> MapWithMove.From_Delete

314− From_Move k -> MapWithMove.From_Move (Some k) Proxy

526+ From_Move (k :=> Flip p) -> MapWithMove.From_Move (Some k) $ g p

315− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)

527+ , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of

528+ To_NonMove -> MapWithMove.To_NonMove

529+ To_Move (k :=> p) -> MapWithMove.To_Move (Some k) $ g p

316 }

530 }

317

531

532+-- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k

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

533+-- 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.

534+-- dependency in the typing and all points are already @a@, hence the function

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

536+patchDMapWithMoveToPatchMapWithMoveWith

537+ :: forall k p p' a

538+ . (PatchTarget1 p a -> PatchTarget p')

539+ -> (p a a -> p')

540+ -> PatchDMapWithMove (Const2 k a) p

541+ -> PatchMapWithMove k p'

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

542+patchDMapWithMoveToPatchMapWithMoveWith f g (PatchDMapWithMove m) =

543+ PatchMapWithMove $ dmapToMapWith h m

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

544+ where h :: NodeInfo (Const2 k a) p a -> MapWithMove.NodeInfo k p'

323− g ni = MapWithMove.NodeInfo

545+ h ni = MapWithMove.NodeInfo

324 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

546 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

325 From_Insert v -> MapWithMove.From_Insert $ f v

547 From_Insert v -> MapWithMove.From_Insert $ f v

326 From_Delete -> MapWithMove.From_Delete

548 From_Delete -> MapWithMove.From_Delete

327− From_Move (Const2 k) -> MapWithMove.From_Move k Proxy

549+ From_Move (Const2 k :=> Flip p) -> MapWithMove.From_Move k $ g p

328− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

550+ , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of

551+ To_NonMove -> MapWithMove.To_NonMove

552+ To_Move (Const2 k :=> p) -> MapWithMove.To_Move k $ g p

329 }

553 }

330

554

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

555+-- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove

556+-- ('Const2' k a)@; that is, turn a non-dependently-typed patch into a

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

557+-- dependently typed one but which always has a constant key type represented by

558+-- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'

333−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

559+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

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

560+const2PatchDMapWithMoveWith

561+ :: forall k v v' a

562+ . (v -> v' a)

563+ -> PatchMapWithMove k (Proxy v)

564+ -> PatchDMapWithMove (Const2 k a) (Proxy3 v')

565+const2PatchDMapWithMoveWith f (PatchMapWithMove p) =

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

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

567+ where g :: (k, MapWithMove.NodeInfo k (Proxy v))

568+ -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))

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

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

338 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

570 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

339 MapWithMove.From_Insert v -> From_Insert $ f v

571 MapWithMove.From_Insert v -> From_Insert $ f v

340 MapWithMove.From_Delete -> From_Delete

572 MapWithMove.From_Delete -> From_Delete

341− MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey

573+ MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3

342− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

574+ , _nodeInfo_to = case MapWithMove._nodeInfo_to ni of

575+ MapWithMove.To_NonMove -> To_NonMove

576+ MapWithMove.To_Move toKey Proxy -> To_Move $ Const2 toKey :=> Proxy3

343 }

577 }

344

578

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

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

580+instance ( GCompare k

581+ , PatchHet2 p

582+ , PatchSource1 p ~ PatchTarget1 p

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

583+ ) => PatchHet (PatchDMapWithMove k p) where

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

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

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

586+

587+instance ( GCompare k

588+ , PatchHet2 p

589+ , PatchSource1 p ~ PatchTarget1 p

590+ ) => 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?

591+ apply (PatchDMapWithMove m) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)

592+ -- TODO: return Nothing sometimes --Note: the strict application here is

593+ -- critical to ensuring that incremental merges don't hold onto all their

594+ -- prerequisite events forever; can we make this more robust?

349− where insertions = DMap.mapMaybeWithKey insertFunc p

595+ where insertions = DMap.mapMaybeWithKey insertFunc m

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

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

351 insertFunc _ ni = case _nodeInfo_from ni of

597 insertFunc _ ni = case _nodeInfo_from ni of

352 From_Insert v -> Just v

598 From_Insert v -> Just v

353− From_Move k -> DMap.lookup k old

599+ From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old

354 From_Delete -> Nothing

600 From_Delete -> Nothing

355− deletions = DMap.mapMaybeWithKey deleteFunc p

601+ deletions = DMap.mapMaybeWithKey deleteFunc m

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

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

357 deleteFunc _ ni = case _nodeInfo_from ni of

603 deleteFunc _ ni = case _nodeInfo_from ni of

358 From_Delete -> Just $ Constant ()

604 From_Delete -> Just $ Constant ()

359 _ -> Nothing

605 _ -> Nothing

360

606

361−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.

607+-- | Get the values that will be replaced, deleted, or moved if the given patch

608+-- is applied to the given 'DMap'.

362−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

609+getDeletionsAndMoves

610+ :: ( GCompare k

611+ , PatchSource1 p ~ PatchTarget1 p

612+ )

613+ => PatchDMapWithMove k p

614+ -> DMap k (PatchSource1 p)

615+ -> DMap k (Product (PatchTarget1 p) (To k p))

363getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

616getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

364 where f _ v ni = Pair v $ _nodeInfo_to ni

617 where f _ v ni = Pair v $ _nodeInfo_to ni

src/Data/Patch/DMapWithMove/By.hsnew file+89

@@ -0,0 +1,89 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE Rank2Types #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+{-# LANGUAGE UndecidableSuperClasses #-}

16+

17+module Data.Patch.DMapWithMove.By where

18+

19+import Data.Semigroupoid as Cat

20+

21+import Data.Patch.Class

22+

23+-- | Structure describing a particular change to a key, be it inserting a new

24+-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting

25+-- a key (@By_Delete@), or moving a key (@By_Move@).

26+--

27+-- This type isn't used directly as the from field patch, but is instead wrapped

28+-- in an existential. However, it is nice to be able to reason about this in

29+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.

30+data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where

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

32+ -- p a@

33+ By_Insert :: PatchTarget1 p to -> By k p from to

34+ -- | Delete the existing key

35+ By_Delete :: By k p from to

36+ -- | Move the value from the given key @k a@ to this key. The source key

37+ -- should also have an entry in the patch giving the current key as

38+ -- @_nodeInfo_to@, usually but not necessarily with @By_Delete@.

39+ By_Move :: !(k from) -> p from to -> By k p from to

40+

41+deriving instance ( Show (k from), Show (k to)

42+ , Show (p from to)

43+ , Show (PatchTarget1 p to)

44+ ) => Show (By k p from to)

45+deriving instance ( Read (k from), Read (k to)

46+ , Read (p from to)

47+ , Read (PatchTarget1 p to)

48+ ) => Read (By k p from to)

49+deriving instance ( Eq (k from), Eq (k to)

50+ , Eq (p from to)

51+ , Eq (PatchTarget1 p to)

52+ ) => Eq (By k p from to)

53+deriving instance ( Ord (k from), Ord (k to)

54+ , Ord (p from to)

55+ , Ord (PatchTarget1 p to)

56+ ) => Ord (By k p from to)

57+

58+mapByPatch

59+ :: PatchTarget1 p0 ~ PatchTarget1 p1

60+ => (p0 from to -> p1 from to)

61+ -> By k p0 from to

62+ -> By k p1 from to

63+mapByPatch f = \case

64+ By_Insert v -> By_Insert v

65+ By_Delete -> By_Delete

66+ By_Move k p -> By_Move k $ f p

67+

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

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

70+instance ( PatchSource1 p ~ PatchTarget1 p

71+ , Cat.Semigroupoid p

72+ , PatchHet2 p

73+ ) => Cat.Semigroupoid (By k p) where

74+ o p0 p1 = mapByPatch unProjectLocal $

75+ oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)

76+

77+oLocal

78+ :: ( PatchSource1 p ~ PatchTarget1 p

79+ , PatchHet2Locally p between after

80+ , Cat.Semigroupoid p

81+ )

82+ => By k p between after

83+ -> By k p before between

84+ -> By k p before after

85+By_Insert new `oLocal` _ = By_Insert new

86+By_Delete `oLocal` _ = By_Delete

87+By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2Locally x y

88+By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y

89+By_Move _ _ `oLocal` By_Delete = By_Delete

src/Data/Patch/IntMap.hs+27−11

@@ -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,15 +19,10 @@ 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) }

20−

23+ deriving ( Show, Read, Eq, Ord

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

24+ , Functor, Foldable, Traversable, Monoid

22−instance Patch (PatchIntMap a) where

25+ )

23− type PatchTarget (PatchIntMap a) = IntMap a

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

25− let removes = IntMap.filter isNothing p

26− adds = IntMap.mapMaybe id p

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

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

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

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

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

@@ -34,6 +32,24 @@ instance Semigroup (PatchIntMap v) where

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

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

35 stimes = stimesIdempotentMonoid

33 stimes = stimesIdempotentMonoid

35+makeWrapped ''PatchIntMap

36+

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

38+instance PatchHet (PatchIntMap a) where

39+ type PatchSource (PatchIntMap a) = IntMap a

40+ type PatchTarget (PatchIntMap a) = IntMap a

41+instance Patch (PatchIntMap a) where

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

43+ let removes = IntMap.filter isNothing p

44+ adds = IntMap.mapMaybe id p

45+ in IntMap.union adds $ v `IntMap.difference` removes

46+

47+instance FunctorWithIndex Int PatchIntMap

48+instance FoldableWithIndex Int PatchIntMap

49+instance TraversableWithIndex Int PatchIntMap where

50+ itraverse = itraversed . Indexed

51+ itraversed = _Wrapped .> itraversed <. traversed

52+

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

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

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

39mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b

55mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b

src/Data/Patch/Map.hs+32−14

@@ -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,11 +22,29 @@ 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'.

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

44+instance Ord k => PatchHet (PatchMap k v) where

45+ type PatchSource (PatchMap k v) = Map k v

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

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

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

23 {-# INLINABLE apply #-}

48 {-# 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?

49 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

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

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

28 Nothing -> Just ()

53 Nothing -> Just ()

29 Just _ -> Nothing

54 Just _ -> Nothing

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

56+instance FunctorWithIndex k (PatchMap k)

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

57+instance FoldableWithIndex k (PatchMap k)

33−-- precedence.

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

58+instance TraversableWithIndex k (PatchMap k) where

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

59+ itraverse = itraversed . Indexed

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

60+ itraversed = _Wrapped .> itraversed <. traversed

37− stimes = stimesIdempotentMonoid

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

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

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

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

41 mempty = PatchMap mempty

64 mempty = PatchMap mempty

42 mappend = (<>)

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

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

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

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

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

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

src/Data/Patch/MapWithMove.hs+77−40

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

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveTraversable #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

@@ -6,6 +7,8 @@

6{-# LANGUAGE PatternGuards #-}

7{-# LANGUAGE PatternGuards #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE StandaloneDeriving #-}

10+{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

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

16import Data.Patch.Class

19import Data.Patch.Class

18import Control.Arrow

21import Control.Arrow

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

19import Control.Monad.Trans.State

23import Control.Monad.Trans.State

20import Data.Foldable

24import Data.Foldable

21import Data.Function

25import Data.Function

@@ -44,12 +48,19 @@ deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMa

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

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

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

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

51+-- -- | Skips the patch so it's 'Functor' and friends

52+-- newtype PatchMapWithMove' k v = PatchMapWithMove' { unPatchMapWithMove' :: PatchMapWithMove k (Proxy v) }

53+--

54+-- deriving instance Functor (PatchMapWithMove' k)

55+-- deriving instance Foldable (PatchMapWithMove' k)

56+-- deriving instance Traversable (PatchMapWithMove' k)

57+

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

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

48-- and where its old value should go to

59-- and where its old value should go to

49data NodeInfo k p = NodeInfo

60data NodeInfo k p = NodeInfo

50 { _nodeInfo_from :: !(From k p)

61 { _nodeInfo_from :: !(From k p)

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

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

52− , _nodeInfo_to :: !(To k)

63+ , _nodeInfo_to :: !(To k p)

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

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

54 -- replaced), where is it going?

65 -- replaced), where is it going?

55 }

66 }

@@ -72,14 +83,30 @@ 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

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

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

74-- that means it will be deleted.

85-- that means it will be deleted.

75−type To = Maybe

86+data To k p

87+ = To_NonMove

88+ | To_Move !k !p

89+ deriving ( Show, Read, Eq, Ord

90+ , Functor, Foldable, Traversable

91+ )

92+

93+makeWrapped ''PatchMapWithMove

94+--makeWrapped ''PatchMapWithMove'

95+

96+-- instance FunctorWithIndex k (PatchMapWithMove k)

97+-- instance FoldableWithIndex k (PatchMapWithMove k)

98+-- instance TraversableWithIndex k (PatchMapWithMove k) where

99+-- itraverse = itraversed . Indexed

100+-- itraversed = _Wrapped .> itraversed <. traversed

101

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

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

78patchMapWithMove

103patchMapWithMove

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

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

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

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

81 where valid = forwardLinks == backwardLinks

106 where valid = forwardLinks == backwardLinks

82− forwardLinks = Map.mapMaybe _nodeInfo_to m

107+ forwardLinks = flip Map.mapMaybe m $ \x -> case _nodeInfo_to x of

108+ To_NonMove -> Nothing

109+ To_Move to _ -> Just to

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

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

84 case _nodeInfo_from p of

111 case _nodeInfo_from p of

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

112 From_Move from _ -> Just (from, to)

@@ -90,13 +117,13 @@ patchMapWithMoveInsertAll

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

117 :: Map k (PatchTarget p) -> PatchMapWithMove k p

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

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

92 { _nodeInfo_from = From_Insert v

119 { _nodeInfo_from = From_Insert v

93− , _nodeInfo_to = Nothing

120+ , _nodeInfo_to = To_NonMove

94 }

121 }

122

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

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

97insertMapKey

124insertMapKey

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

125 :: k -> PatchTarget p -> PatchMapWithMove k p

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

126+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) To_NonMove

100

127

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:

128-- |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:

102--

129--

@@ -109,8 +136,8 @@ moveMapKey src dst

109 | src == dst = mempty

136 | src == dst = mempty

110 | otherwise =

137 | otherwise =

111 PatchMapWithMove $ Map.fromList

138 PatchMapWithMove $ Map.fromList

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

139+ [ (dst, NodeInfo (From_Move src mempty) To_NonMove)

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

140+ , (src, NodeInfo From_Delete (To_Move dst mempty))

114 ]

141 ]

115

142

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

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

@@ -129,15 +156,15 @@ swapMapKey src dst

129 | src == dst = mempty

156 | src == dst = mempty

130 | otherwise =

157 | otherwise =

131 PatchMapWithMove $ Map.fromList

158 PatchMapWithMove $ Map.fromList

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

159+ [ (dst, NodeInfo (From_Move src mempty) (To_Move dst mempty))

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

160+ , (src, NodeInfo (From_Move dst mempty) (To_Move dst mempty))

134 ]

161 ]

135

162

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

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

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

164-- the mapping, equivalent to 'Map.delete'.

138deleteMapKey

165deleteMapKey

139 :: k -> PatchMapWithMove k v

166 :: k -> PatchMapWithMove k v

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

167+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete To_NonMove

141

168

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

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

143--

170--

@@ -147,8 +174,11 @@ unsafePatchMapWithMove

147unsafePatchMapWithMove = PatchMapWithMove

174unsafePatchMapWithMove = PatchMapWithMove

148

175

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

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

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

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

178+ type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)

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

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

180+

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

152 -- TODO: return Nothing sometimes

182 -- TODO: return Nothing sometimes

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

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

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

@@ -191,7 +221,7 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW

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

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

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

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

193 let Just movingTo = Map.lookup from reverseMapping

223 let Just movingTo = Map.lookup from reverseMapping

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

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

195

225

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

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

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

@@ -218,25 +248,32 @@ patchThatChangesMap oldByIndex newByIndex = patch

218 then Map.delete v remainingValues

248 then Map.delete v remainingValues

219 else Map.insert v remainingKeys remainingValues

249 else Map.insert v remainingKeys remainingValues

220 case Map.lookup v remainingValues of

250 case Map.lookup v remainingValues of

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

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

222 Just fromKs ->

252 Just fromKs ->

223 if k `Set.member` fromKs

253 if k `Set.member` fromKs

224 then do

254 then do

225 putRemainingKeys $ Set.delete k fromKs

255 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

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

227 else do

257 else do

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

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

229 putRemainingKeys remainingKeys

259 putRemainingKeys remainingKeys

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

260+ return $ NodeInfo (From_Move fromK mempty) $ To_Move undefined undefined

231 Map.traverseWithKey f newByIndex

261 Map.traverseWithKey f newByIndex

232 unusedOldKeys = fold unusedValuesByValue

262 unusedOldKeys = fold unusedValuesByValue

233 pointlessMove k = \case

263 pointlessMove k = \case

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

264 From_Move k' _ | k == k' -> True

235 _ -> False

265 _ -> False

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

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

237− then Just undefined

267+ then To_Move undefined undefined

238− else Nothing

268+ else To_NonMove

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

269+ patch = unsafePatchMapWithMove $ Map.filterWithKey

270+ (\k -> not . pointlessMove k . _nodeInfo_from)

271+ $ Map.mergeWithKey

272+ (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a)

273+ (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k)

274+ (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k)

275+ insertsAndMoves

276+ oldByIndex

240

277

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

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

242nodeInfoMapFrom

279nodeInfoMapFrom

@@ -251,35 +288,41 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _

251

288

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

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

253nodeInfoSetTo

290nodeInfoSetTo

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

291+ :: To k p -> NodeInfo k p -> NodeInfo k p

255nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

292nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

256

293

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

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

258−data Fixup k v

295+data Fixup k p

259 = Fixup_Delete

296 = Fixup_Delete

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

297+ | Fixup_Update (These (From k p) (To k p))

261

298

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

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

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

263instance ( Ord k

301instance ( Ord k

264− , Monoid p

265 , DecidablyEmpty p

302 , DecidablyEmpty p

266 , Patch p

303 , Patch p

267 ) => Semigroup (PatchMapWithMove k p) where

304 ) => Semigroup (PatchMapWithMove k p) where

268 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

305 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

269 where

306 where

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

307 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)]

308+ h :: (k, (To k p, From k p)) -> [(k, Fixup k p)]

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

309+ h (_, (editAfter, editBefore)) = case (editAfter, editBefore) of

273− (Just toAfter, From_Move fromBefore p)

310+ (To_Move toAfter p1, From_Move fromBefore p0)

274− | fromBefore == toAfter && isNull p

311+ | fromBefore == toAfter && isNull p0

275 -> [(toAfter, Fixup_Delete)]

312 -> [(toAfter, Fixup_Delete)]

276 | otherwise

313 | otherwise

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

314+ -> [ (toAfter, Fixup_Update (This $ From_Move fromBefore $ p1 <> p0))

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

315+ , (fromBefore, Fixup_Update (That $ To_Move toAfter $ p1 <> p0))

279 ]

316 ]

317+ (To_NonMove, From_Move fromBefore _) ->

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

318+ -- The item is destroyed in the second patch, so indicate that it is

319+ -- destroyed in the source map

320+ [(fromBefore, Fixup_Update (That editAfter))]

321+ (To_Move toAfter p, From_Insert val) ->

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

322+ [(toAfter, Fixup_Update $ This $ From_Insert $ applyAlways p val)]

282− (Nothing, _) -> []

323+ (To_Move toAfter _, From_Delete) ->

324+ [(toAfter, Fixup_Update $ This From_Delete)]

325+ (To_NonMove, _) -> []

283 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

326 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

284 mergeFixups _ (Fixup_Update a) (Fixup_Update b)

327 mergeFixups _ (Fixup_Update a) (Fixup_Update b)

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

328 | This x <- a, That y <- b

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

295 applyFixup _ ni = \case

338 applyFixup _ ni = \case

296 Fixup_Delete -> Nothing

339 Fixup_Delete -> Nothing

297 Fixup_Update u -> Just $ NodeInfo

340 Fixup_Update u -> Just $ NodeInfo

298− { _nodeInfo_from = case _nodeInfo_from ni of

341+ { _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

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

306 }

343 }

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

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