44719da..develop · patch

git.iko.soy/patch

11 files changed+207−276

unifiedsplit

.github/workflows/haskell.yml+3−1 .travis.yml−171 ChangeLog.md+16−8 cabal.haskell-ci−14 patch.cabal+19−2 src/Data/Patch.hs+3−14 src/Data/Patch/DMapWithMove.hs+2−2 src/Data/Patch/MapWithMove.hs+26−28 src/Data/Patch/MapWithPatchingMove.hs+41−36 src/Data/Semigroup/Additive.hs+54 test/tests.hs+43

.github/workflows/haskell.yml+3−1

@@ -42,4 +42,6 @@ jobs:

4242 - name: Build

4343 run: cabal build --enable-tests --enable-benchmarks all

4444 - name: Run tests

45− run: cabal test all

45+ run: cabal test --enable-tests all

46+ - name: Build Docs

47+ run: cabal haddock

.travis.ymldeleted−171

@@ -1,171 +0,0 @@

1−# This Travis job script has been generated by a script via

2−#

3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'

4−#

5−# For more information, see https://github.com/haskell-CI/haskell-ci

6−#

7−# version: 0.3.20190814

8−#

9−language: c

10−dist: xenial

11−sudo: required

12−git:

13− # whether to recursively clone submodules

14− submodules: false

15−cache:

16− directories:

17− - $HOME/.cabal/packages

18− - $HOME/.cabal/store

19−before_cache:

20− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

21− # remove files that are regenerated by 'cabal update'

22− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

23− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

27− - rm -rfv $CABALHOME/packages/head.hackage

28−matrix:

29− include:

30− - compiler: ghcjs-8.4

31− addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}

32− - compiler: ghc-8.8.1

33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}

34− - compiler: ghc-8.6.5

35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}

36− - compiler: ghc-8.4.4

37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}

38− - compiler: ghc-8.2.2

39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}

40− - compiler: ghc-8.0.2

41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}

42−before_install:

43− - |

44− if [ "$TRAVIS_OS_NAME" = "linux" ]; then

45− sudo add-apt-repository -y ppa:hvr/ghcjs;

46− curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -

47− sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main'

48− sudo apt-get update;

49− sudo apt-get install $CC cabal-install-3.0 nodejs;

50− fi

51− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

52− - WITHCOMPILER="-w $HC"

53− - |

54− if echo $CC | grep -q ghcjs; then

55− GHCJS=true

56− HC=${HC}js

57− WITHCOMPILER="--ghcjs ${WITHCOMPILER}js"

58− else

59− GHCJS=false;

60− fi

61− - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi

62− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi

63− - HCPKG="$HC-pkg"

64− - unset CC

65− - CABAL=/opt/ghc/bin/cabal

66− - CABALHOME=$HOME/.cabal

67− - export PATH="$CABALHOME/bin:$PATH"

68− - TOP=$(pwd)

69− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"

70− - echo $HCNUMVER

71− - CABAL="$CABAL -vnormal+nowrap+markoutput"

72− - set -o pipefail

73− - |

74− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk

75− echo 'BEGIN { state = "output"; }' >> .colorful.awk

76− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk

77− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk

78− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk

79− echo ' if (state == "cabal") {' >> .colorful.awk

80− echo ' print blue($0)' >> .colorful.awk

81− echo ' } else {' >> .colorful.awk

82− echo ' print $0' >> .colorful.awk

83− echo ' }' >> .colorful.awk

84− echo '}' >> .colorful.awk

85− - cat .colorful.awk

86− - |

87− color_cabal_output () {

88− awk -f $TOP/.colorful.awk

89− }

90− - echo text | color_cabal_output

91−install:

92− - ${CABAL} --version

93− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

94− - node --version

95− - echo $GHCJS

96− - TEST=--enable-tests

97− - BENCH=--enable-benchmarks

98− - BENCH=--disable-benchmarks

99− - HEADHACKAGE=false

100− - rm -f $CABALHOME/config

101− - |

102− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config

103− echo "remote-build-reporting: anonymous" >> $CABALHOME/config

104− echo "write-ghc-environment-files: always" >> $CABALHOME/config

105− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config

106− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config

107− echo "world-file: $CABALHOME/world" >> $CABALHOME/config

108− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config

109− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config

110− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config

111− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config

112− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config

113− echo "install-dirs user" >> $CABALHOME/config

114− echo " prefix: $CABALHOME" >> $CABALHOME/config

115− echo "repository hackage.haskell.org" >> $CABALHOME/config

116− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config

117− - cat $CABALHOME/config

118− - rm -fv cabal.project cabal.project.local cabal.project.freeze

119− - travis_retry ${CABAL} v2-update -v

120− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi

121− # Generate cabal.project

122− - rm -rf cabal.project cabal.project.local cabal.project.freeze

123− - touch cabal.project

124− - |

125− echo "packages: ." >> cabal.project

126− - |

127− - cat cabal.project || true

128− - cat cabal.project.local || true

129− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

130− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output

131− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

132− - rm cabal.project.freeze

133−script:

134− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

135− # Packaging...

136− - ${CABAL} v2-sdist all | color_cabal_output

137− # Unpacking...

138− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

139− - cd ${DISTDIR} || false

140− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

141− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;

142− - PKGDIR_patch="$(find . -maxdepth 1 -type d -regex '.*/patch-[0-9.]*')"

143− # Generate cabal.project

144− - rm -rf cabal.project cabal.project.local cabal.project.freeze

145− - touch cabal.project

146− - |

147− echo "packages: ${PKGDIR_patch}" >> cabal.project

148− - |

149− - cat cabal.project || true

150− - cat cabal.project.local || true

151− # Building...

152− # this builds all libraries and executables (without tests/benchmarks)

153− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

154− # Building with tests and benchmarks...

155− # build & run tests, build benchmarks

156− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

157− # Testing...

158− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

159− # cabal check...

160− - (cd ${PKGDIR_patch} && ${CABAL} -vnormal check)

161− # haddock...

162− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

163− # Constraint sets

164− - rm -rf cabal.project.local

165− # Constraint set old-these

166− - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi

167− # Constraint set old-witherable

168− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output

169−

170−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]

171−# EOF

ChangeLog.md+16−8

@@ -2,31 +2,39 @@

33## Unreleased

5+* New dep of `data-orphans` for old GHC to get instances honestly instead of

6+ via `monoidal-containers`.

8+## 0.0.5.0 - 2021-12-17

10+* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported

11+ from `Data.Patch` for compatability.

12+

513* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.

614 Care is taken to make this not a breaking change.

715 In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.

816 There are complete constructor and field patterns too, and everything is

917 exported under the newtype as real constructors and fields would be.

1018

11−## 0.0.4.0

19+## 0.0.4.0 - 2021-04-20

1220

1321* Enable PolyKinds

1422

15−## 0.0.3.2

23+## 0.0.3.2 - 2020-11-06

1624

1725* Update version bounds

1826

19−## 0.0.3.1

27+## 0.0.3.1 - 2020-02-05

2028

2129* Replace `fromJust` with something easier to debug.

2230

23−## 0.0.3.0

31+## 0.0.3.0 - 2020-02-05

2432

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

2634

2735* Create `DecidablyEmpty` subclass of `Monoid`.

2836

29−## 0.0.2.0

37+## 0.0.2.0 - 2020-01-17

3038

3139* Consistently provide:

3240

@@ -38,16 +46,16 @@

3846

3947 for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.

4048

41−## 0.0.1.0

49+## 0.0.1.0 - 2020-01-09

4250

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

4452

4553* Additional instances for the `Group` class for basic types.

4654

47−## 0.0.0.1

55+## 0.0.0.1 - 2020-01-08

4856

4957* Remove unneeded dependencies

5058

51−## 0.0.0.0

59+## 0.0.0.0 - 2020-01-08

5260

5361* Extract patching functionality from Reflex.

cabal.haskell-cideleted−14

@@ -1,14 +0,0 @@

1−distribution: xenial

2−benchmarks: False

3−unconstrained: False

4−installed: -all

5−

6−-- https://github.com/haskell/cabal/issues/6106

7−install-dependencies: False

8−

9−constraint-set old-these

10− ghc: <8.8

11− constraints: these <1

12−

13−constraint-set old-witherable

14− constraints: witherable <0.3.2

patch.cabal+19−2

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

11Name: patch

2−Version: 0.0.4.0

2+Version: 0.0.5.0

33Synopsis: Data structures for describing changes to other data structures.

44Description:

55 Data structures for describing changes to other data structures.

@@ -41,7 +41,10 @@ library

4141 , lens >= 4.7 && < 5

4242 , semigroupoids >= 4.0 && < 6

4343 , transformers >= 0.5.6.0 && < 0.6

44− , witherable >= 0.3 && < 0.4

44+ , witherable >= 0.3 && < 0.5

45+

46+ if impl(ghc < 8.6) -- really, if base < 8.12

47+ build-depends: base-orphans >= 0.8 && < 0.9

4548

4649 exposed-modules: Data.Functor.Misc

4750 , Data.Monoid.DecidablyEmpty

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

5356 , Data.Patch.Map

5457 , Data.Patch.MapWithMove

5558 , Data.Patch.MapWithPatchingMove

59+ , Data.Semigroup.Additive

5660

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

5862 default-extensions: PolyKinds

@@ -65,6 +69,19 @@ library

6569 build-depends: these >= 0.4 && <0.9

6670 , monoidal-containers == 0.4.0.0

6771

72+test-suite tests

73+ default-language: Haskell2010

74+ type: exitcode-stdio-1.0

75+ main-is: tests.hs

76+ hs-source-dirs: test

77+ build-depends: base

78+ , patch

79+ , containers

80+ , hedgehog

81+ , HUnit

82+ if impl(ghcjs)

83+ buildable: False

84+

6885test-suite hlint

6986 default-language: Haskell2010

7087 type: exitcode-stdio-1.0

src/Data/Patch.hs+3−14

@@ -23,6 +23,7 @@ import Data.Semigroup (Semigroup (..))

2323#endif

2424import GHC.Generics

2525

26+import Data.Semigroup.Additive as X

2627import Data.Patch.Class as X

2728import Data.Patch.DMap as X hiding (getDeletions)

2829import Data.Patch.DMapWithMove as X

@@ -45,9 +46,6 @@ class (Semigroup q, Monoid q) => Group q where

4546 (~~) :: q -> q -> q

4647 r ~~ s = r <> negateG s

4748

48−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative

49−class Semigroup q => Additive q where

50−

5149-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.

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

5351

@@ -58,19 +56,15 @@ instance Additive p => Patch (AdditivePatch p) where

5856instance (Ord k, Group q) => Group (MonoidalMap k q) where

5957 negateG = fmap negateG

6058

61−instance (Ord k, Additive q) => Additive (MonoidalMap k q)

62−

6359-- | Trivial group.

6460instance Group () where

6561 negateG _ = ()

6662 _ ~~ _ = ()

67−instance Additive ()

6863

6964-- | Product group. A Pair of groups gives rise to a group

7065instance (Group a, Group b) => Group (a, b) where

7166 negateG (a, b) = (negateG a, negateG b)

7267 (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)

73−instance (Additive a, Additive b) => Additive (a, b)

7468

7569-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.

7670-- Base does not define Monoid (Compose f g a) so this is the best we can

@@ -78,29 +72,24 @@ instance (Additive a, Additive b) => Additive (a, b)

7872instance Group (f (g a)) => Group ((f :.: g) a) where

7973 negateG (Comp1 xs) = Comp1 (negateG xs)

8074 Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)

81−instance Additive (f (g a)) => Additive ((f :.: g) a)

8275

8376-- | Product of groups, Functor style.

8477instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where

8578 negateG (a :*: b) = negateG a :*: negateG b

8679 (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)

87−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)

8880

8981-- | Trivial group, Functor style

9082instance Group (Proxy x) where

9183 negateG _ = Proxy

9284 _ ~~ _ = Proxy

93−instance Additive (Proxy x)

9485

9586-- | Const lifts groups into a functor.

9687deriving instance Group a => Group (Const a x)

97−instance Additive a => Additive (Const a x)

98−-- | Ideitnty lifts groups pointwise (at only one point)

88+

89+-- | Identity lifts groups pointwise (at only one point)

9990deriving instance Group a => Group (Identity a)

100−instance Additive a => Additive (Identity a)

10191

10292-- | Functions lift groups pointwise.

10393instance Group b => Group (a -> b) where

10494 negateG f = negateG . f

10595 (~~) = liftA2 (~~)

106−instance Additive b => Additive (a -> b)

src/Data/Patch/DMapWithMove.hs+2−2

@@ -220,8 +220,8 @@ moveDMapKey src dst = case src `geq` dst of

220220-- @

221221-- let aMay = DMap.lookup a dmap

222222-- bMay = DMap.lookup b dmap

223−-- in maybe id (DMap.insert a) (bMay `mplus` aMay)

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

223+-- in maybe id (DMap.insert a) (bMay <> aMay)

224+-- . maybe id (DMap.insert b) (aMay <> bMay)

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

226226-- @

227227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

src/Data/Patch/MapWithMove.hs+26−28

@@ -19,9 +19,7 @@

1919module Data.Patch.MapWithMove

2020 ( PatchMapWithMove

2121 ( PatchMapWithMove

22− , -- | Extract the representation of the 'PatchMapWithMove' as a map of

23− -- 'NodeInfo'.

24− unPatchMapWithMove

22+ , unPatchMapWithMove

2523 , ..

2624 )

2725 , patchMapWithMove

@@ -65,13 +63,10 @@ module Data.Patch.MapWithMove

6563import Data.Coerce

6664import Data.Kind (Type)

6765import Data.Patch.Class

68−import Data.Patch.MapWithPatchingMove

69− ( PatchMapWithPatchingMove (..)

70− )

71−import qualified Data.Patch.MapWithPatchingMove as PM

72−import Data.Patch.MapWithPatchingMove (To) -- already a transparent synonym

66+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)

67+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym

7368

74−import Control.Lens hiding (from, to)

69+import Control.Lens

7570import Data.List

7671import Data.Map (Map)

7772import qualified Data.Map as Map

@@ -89,9 +84,13 @@ newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'

8984 unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)

9085 }

9186 deriving ( Show, Read, Eq, Ord

92− , -- | Compose patches having the same effect as applying the

87+-- Haddock cannot handle documentation here before GHC 8.6

88+ ,

89+#if __GLASGOW_HASKELL__ >= 806

90+ -- | Compose patches having the same effect as applying the

9391 -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .

9492 -- 'applyAlways' q@

93+#endif

9594 Semigroup

9695 , Monoid

9796 )

@@ -102,6 +101,8 @@ pattern Coerce x <- (coerce -> x)

102101

103102{-# COMPLETE PatchMapWithMove #-}

104103pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

104+-- | Extract the representation of the 'PatchMapWithMove' as a map of

105+-- 'NodeInfo'.

105106unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

106107pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))

107108

@@ -136,7 +137,7 @@ instance TraversableWithIndex k (PatchMapWithMove k) where

136137

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

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

139−patchMapWithMove = fmap coerce . PM.patchMapWithPatchingMove . coerce

140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce

140141

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

142143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v

@@ -159,8 +160,8 @@ moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst

159160-- @

160161-- let aMay = Map.lookup a map

161162-- bMay = Map.lookup b map

162−-- in maybe id (Map.insert a) (bMay `mplus` aMay)

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

163+-- in maybe id (Map.insert a) (bMay <> aMay)

164+-- . maybe id (Map.insert b) (aMay <> bMay)

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

165166-- @

166167swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v

@@ -174,7 +175,7 @@ deleteMapKey = PatchMapWithMove' . PM.deleteMapKey

174175--

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

176177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

177−unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce

178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove

178179

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

180181instance Ord k => Patch (PatchMapWithMove k v) where

@@ -198,7 +199,7 @@ patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp

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

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

200201-- values sorted with the given ordering function.

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

202+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

202203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

203204 where newList = Map.toList newByIndexUnsorted

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

@@ -226,11 +227,11 @@ deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)

226227pattern NodeInfo :: To k -> From k v -> NodeInfo k v

227228_nodeInfo_to :: NodeInfo k v -> To k

228229_nodeInfo_from :: NodeInfo k v -> From k v

229−pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } =

230− NodeInfo' (PM.NodeInfo

230+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'

231+ PM.NodeInfo

231232 { PM._nodeInfo_to = _nodeInfo_to

232233 , PM._nodeInfo_from = Coerce _nodeInfo_from

233− })

234+ }

234235

235236_NodeInfo

236237 :: Iso

@@ -247,24 +248,20 @@ instance Foldable (NodeInfo k) where

247248 foldMap = foldMapDefault

248249

249250instance Traversable (NodeInfo k) where

250− traverse = _NodeInfo . traverseNodeInfo

251− where

252− traverseNodeInfo

253− :: Traversal (PM.NodeInfo k (Proxy a)) (PM.NodeInfo k (Proxy b)) a b

254− traverseNodeInfo = PM.bitraverseNodeInfo pure (\ ~Proxy -> pure Proxy)

251+ traverse = bitraverseNodeInfo pure

255252

256253bitraverseNodeInfo

257254 :: Applicative f

258255 => (k0 -> f k1)

259256 -> (v0 -> f v1)

260257 -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)

261−bitraverseNodeInfo fk fv = fmap coerce

258+bitraverseNodeInfo fk fv = fmap NodeInfo'

262259 . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv

263260 . coerce

264261

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

266263nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

267−nodeInfoMapFrom f = coerce . PM.nodeInfoMapFrom (unFrom' . f . From') . coerce

264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')

268265

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

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

@@ -272,7 +269,7 @@ nodeInfoMapMFrom

272269 :: Functor f

273270 => (From k v -> f (From k v))

274271 -> NodeInfo k v -> f (NodeInfo k v)

275−nodeInfoMapMFrom f = fmap coerce

272+nodeInfoMapMFrom f = fmap NodeInfo'

276273 . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')

277274 . coerce

278275

@@ -295,7 +292,7 @@ pattern From_Insert v = From' (PM.From_Insert v)

295292

296293-- | Delete the existing value, if any, from here

297294pattern From_Delete :: From k v

298−pattern From_Delete = From' (PM.From_Delete)

295+pattern From_Delete = From' PM.From_Delete

299296

300297-- | Move the value here from the given key

301298pattern From_Move :: k -> From k v

@@ -306,9 +303,10 @@ bitraverseFrom

306303 => (k0 -> f k1)

307304 -> (v0 -> f v1)

308305 -> From k0 v0 -> f (From k1 v1)

309−bitraverseFrom fk fv = fmap coerce

306+bitraverseFrom fk fv = fmap From'

310307 . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv

311308 . coerce

312309

313310makeWrapped ''PatchMapWithMove

314311makeWrapped ''NodeInfo

312+makeWrapped ''From

src/Data/Patch/MapWithPatchingMove.hs+41−36

@@ -48,10 +48,10 @@ module Data.Patch.MapWithPatchingMove

4848

4949import Data.Patch.Class

5050

51−import Control.Arrow

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

5252import Control.Lens.TH (makeWrapped)

53−import Control.Monad.Trans.State

54−import Data.Foldable

53+import Data.Align (align)

54+import Data.Foldable (toList)

5555import Data.Function

5656import Data.List

5757import Data.Map (Map)

@@ -61,9 +61,9 @@ import Data.Maybe

6161import Data.Semigroup (Semigroup (..))

6262#endif

6363import Data.Monoid.DecidablyEmpty

64+import Data.Set (Set)

6465import qualified Data.Set as Set

6566import Data.These (These (..))

66−import Data.Tuple

6767

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

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

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

136136-- @

137137-- let aMay = Map.lookup a map

138138-- bMay = Map.lookup b map

139−-- in maybe id (Map.insert a) (bMay `mplus` aMay)

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

139+-- in maybe id (Map.insert a) (bMay <> aMay)

140+-- . maybe id (Map.insert b) (aMay <> bMay)

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

142142-- @

143143swapMapKey

@@ -229,39 +229,40 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha

229229

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

231231-- will produce the second 'Map'.

232+-- Note: this will never produce a patch on a value.

232233patchThatChangesMap

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

234+ :: forall k p

235+ . (Ord k, Ord (PatchTarget p), Monoid p)

234236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

235237patchThatChangesMap oldByIndex newByIndex = patch

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

237− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

238− let f k v = do

239− remainingValues <- get

240− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

241− then Map.delete v remainingValues

242− else Map.insert v remainingKeys remainingValues

243− case Map.lookup v remainingValues of

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

245− Just fromKs ->

246− if k `Set.member` fromKs

247− then do

248− putRemainingKeys $ Set.delete k fromKs

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

250− else do

251− (fromK, remainingKeys) <- return $

252− fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $

253− Set.minView fromKs -- There's an existing value, but it's not here; move it here

254− putRemainingKeys remainingKeys

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

256− Map.traverseWithKey f newByIndex

257− unusedOldKeys = fold unusedValuesByValue

258− pointlessMove k = \case

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

260− _ -> False

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

262− then Just undefined

263− else Nothing

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

238+ where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)

239+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList

240+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function

241+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'

242+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")

243+ unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))

244+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)

245+ -- Generate patch info for a single value

246+ -- Keys that are found in both the old and new sets will not be patched

247+ -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted

248+ -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted

249+ patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))

250+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case

251+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it

252+ That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it

253+ These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)

254+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty

255+ patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))

256+ patchSingleValueThese v = \case

257+ This oldKeys -> patchSingleValue v oldKeys mempty

258+ That newKeys -> patchSingleValue v mempty newKeys

259+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys

260+ -- Generate froms and tos for all values, then merge them together

261+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)

262+ patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case

263+ This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.

264+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted

265+ These from to -> NodeInfo from to

265266

266267--

267268-- NodeInfo

@@ -281,6 +282,8 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)

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

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

283284

285+-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of

286+-- the type families here, this doesn't it any bi- or tri-traversal class.

284287bitraverseNodeInfo

285288 :: Applicative f

286289 => (k0 -> f k1)

@@ -322,6 +325,8 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)

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

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

324327

328+-- | Traverse the 'From' over the key, patch, and patch target. Because of

329+-- the type families here, this doesn't it any bi- or tri-traversal class.

325330bitraverseFrom

326331 :: Applicative f

327332 => (k0 -> f k1)

src/Data/Semigroup/Additive.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

4+-- |

5+-- Module:

6+-- Data.Semigroup.Additive

7+-- Description:

8+-- This module defines a class for commutative semigroups, until it is moved

9+-- to another library.

10+module Data.Semigroup.Additive

11+ ( Additive

12+ ) where

13+

14+import Data.Functor.Const (Const (..))

15+import Data.Functor.Identity

16+import Data.Proxy

17+#if !MIN_VERSION_base(4,12,0)

18+-- for :*: and :.: semigroup instances

19+import Data.Orphans ()

20+#endif

21+#if !MIN_VERSION_base(4,11,0)

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

23+#endif

24+import GHC.Generics

25+

26+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative

27+class Semigroup q => Additive q where

28+

29+-- | Trivial additive semigroup.

30+instance Additive ()

31+

32+-- | Product additive semigroup.

33+-- A Pair of additive semigroups gives rise to a additive semigroup

34+instance (Additive a, Additive b) => Additive (a, b)

35+

36+-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.

37+-- Base does not define Monoid (Compose f g a) so this is the best we can

38+-- really do for functor composition.

39+instance Additive (f (g a)) => Additive ((f :.: g) a)

40+

41+-- | Product of additive semigroups, Functor style.

42+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)

43+

44+-- | Trivial additive semigroup, Functor style

45+instance Additive (Proxy x)

46+

47+-- | Const lifts additive semigroups into a functor.

48+instance Additive a => Additive (Const a x)

49+

50+-- | Identity lifts additive semigroups pointwise (at only one point)

51+instance Additive a => Additive (Identity a)

52+

53+-- | Functions lift additive semigroups pointwise.

54+instance Additive b => Additive (a -> b)

test/tests.hsnew file+43

@@ -0,0 +1,43 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+module Main where

4+import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)

5+import Data.Patch ( Patch(apply) )

6+import Data.Patch.MapWithMove ( patchThatChangesMap )

7+import Data.Map as Map ( Map, fromList, singleton )

8+import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))

9+import Hedgehog.Gen as Gen ( int )

10+import Hedgehog.Range as Range ( linear )

11+import Control.Monad (replicateM)

12+import System.Exit (exitFailure, exitSuccess)

13+import Data.Sequence as Seq ( foldMapWithIndex, replicateM )

14+

15+main :: IO ()

16+main = do

17+ counts <- runTestTT $ test [

18+ "Simple Move" ~: (do

19+ let mapBefore = Map.fromList [(0,1)]

20+ mapAfter = Map.fromList [(0,0),(1,1)]

21+ patch = patchThatChangesMap mapBefore mapAfter

22+ afterPatch = apply patch mapBefore

23+ assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),

24+ "Property Checks" ~: propertyChecks

25+ ]

26+ if errors counts + failures counts == 0 then exitSuccess else exitFailure

27+

28+propertyChecks :: IO Bool

29+propertyChecks = checkParallel $$(discover)

30+

31+prop_patchThatChangesMap :: Property

32+prop_patchThatChangesMap = property $ do

33+ mapBefore <- makeRandomIntMap

34+ mapAfter <- makeRandomIntMap

35+ let patch = patchThatChangesMap mapBefore mapAfter

36+ Just mapAfter === apply patch mapBefore

37+

38+makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)

39+makeRandomIntMap = do

40+ let genNum = Gen.int (Range.linear 0 100)

41+ length <- forAll genNum

42+ listOfNumbers <- forAll $ Seq.replicateM length genNum

43+ pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers