cfcd1cf · patch · git.iko.soy

git.iko.soy/patch

Merge branch 'develop' into patch-map-inner-patch-desugar

commitcfcd1cf521a997eca5a4f2268872b349ee881505 authorJohn Ericson <John.Ericson@Obsidian.Systems> dateWed 5 Feb 2020, 14:38 (7 years ago) parent8cd0fc5 e1e7268

11 files changed+180−29

compare with develop

unifiedsplit

ChangeLog.md+3−1 patch.cabal+1−1 src/Data/Monoid/DecidablyEmpty.hs+103−2 src/Data/Patch.hs+1−1 src/Data/Patch/Class.hs+3 src/Data/Patch/DMap.hs+9 src/Data/Patch/DMapWithMove.hs+8−1 src/Data/Patch/IntMap.hs+9−6 src/Data/Patch/Map.hs+9−8 src/Data/Patch/MapWithMove.hs+1−1 src/Data/Patch/MapWithPatchingMove.hs+33−8

ChangeLog.md+3−1

@@ -1,9 +1,11 @@

11# Revision history for patch

3−## Unreleased

3+## 0.0.3.0

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

7+* Create `DecidablyEmpty` subclass of `Monoid`.

79## 0.0.2.0

810

911* Consistently provide:

patch.cabal+1−1

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

11Name: patch

2−Version: 0.0.2.0

2+Version: 0.0.3.0

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

44Description:

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

src/Data/Monoid/DecidablyEmpty.hs+103−2

@@ -1,14 +1,115 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DefaultSignatures #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

37-- TODO upstream somwhere else?

48module Data.Monoid.DecidablyEmpty where

10+import Data.Functor.Identity

11+import Data.Functor.Const

12+import Data.Monoid

13+import Data.Maybe (isNothing)

14+#if MIN_VERSION_base(4,11,0)

15+import Data.Ord

16+#endif

617import Data.Proxy

18+import Data.Semigroup hiding (First, Last)

19+#if MIN_VERSION_base(4,12,0)

20+import GHC.Generics

21+#endif

722

23+import qualified Data.IntSet as IntSet

24+import qualified Data.IntMap as IntMap

25+import qualified Data.Map as Map

26+import qualified Data.Sequence as Seq

27+import qualified Data.Set as Set

28+

29+import Data.GADT.Compare

30+import qualified Data.Dependent.Map as DMap

31+

32+-- | A 'DecidablyEmpty' is one where it can be computed whether or not an

33+-- arbitrary value is 'mempty'.

34+--

35+-- By using this class rather than 'Eq', we avoid unnecessary constraining the

36+-- contents of 'Functor's. This makes it possible to efficiently combine and/or

37+-- nest patch maps with 'Eq'-lacking values (e.g. functions) at the leaves.

838class Monoid a => DecidablyEmpty a where

939 isEmpty :: a -> Bool

1040 default isEmpty :: Eq a => a -> Bool

1141 isEmpty = (==) mempty

1242

13−instance DecidablyEmpty (Proxy a) where

14− isEmpty ~Proxy = True

43+-- base

44+

45+instance DecidablyEmpty Ordering

46+instance DecidablyEmpty ()

47+instance DecidablyEmpty Any

48+instance DecidablyEmpty All

49+-- instance DecidablyEmpty Lifetime

50+-- instance DecidablyEmpty Event

51+instance DecidablyEmpty [a] where

52+ isEmpty = null

53+instance

54+#if MIN_VERSION_base(4,11,0)

55+ Semigroup a

56+#else

57+ Monoid a

58+#endif

59+ => DecidablyEmpty (Maybe a) where

60+ isEmpty = isNothing

61+deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a)

62+deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a)

63+deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a)

64+instance DecidablyEmpty (First a) where

65+ isEmpty (First a) = isNothing a

66+instance DecidablyEmpty (Last a) where

67+ isEmpty (Last a) = isNothing a

68+deriving instance DecidablyEmpty a => DecidablyEmpty (Identity a)

69+instance Semigroup a => DecidablyEmpty (Option a) where

70+ isEmpty (Option a) = isNothing a

71+deriving instance DecidablyEmpty m => DecidablyEmpty (WrappedMonoid m)

72+instance (Ord a, Bounded a) => DecidablyEmpty (Max a)

73+instance (Ord a, Bounded a) => DecidablyEmpty (Min a)

74+instance DecidablyEmpty (Proxy s)

75+deriving instance DecidablyEmpty a => DecidablyEmpty (Const a b)

76+#if MIN_VERSION_base(4,11,0)

77+deriving instance DecidablyEmpty a => DecidablyEmpty (Down a)

78+#endif

79+#if MIN_VERSION_base(4,12,0)

80+deriving instance DecidablyEmpty p => DecidablyEmpty (Par1 p)

81+instance DecidablyEmpty (U1 p)

82+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (Rec1 f p)

83+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (M1 i c f p)

84+deriving instance DecidablyEmpty c => DecidablyEmpty (K1 i c p)

85+instance (DecidablyEmpty (f p), DecidablyEmpty (g p)) => DecidablyEmpty ((f :*: g) p) where

86+ isEmpty (x :*: y) = isEmpty x && isEmpty y

87+deriving instance DecidablyEmpty (f (g p)) => DecidablyEmpty ((f :.: g) p)

88+#endif

89+

90+instance (DecidablyEmpty a, DecidablyEmpty b) => DecidablyEmpty (a, b) where

91+ isEmpty (a, b) = isEmpty a && isEmpty b

92+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c) => DecidablyEmpty (a, b, c) where

93+ isEmpty (a, b, c) = isEmpty a && isEmpty b && isEmpty c

94+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d) => DecidablyEmpty (a, b, c, d) where

95+ isEmpty (a, b, c, d) = isEmpty a && isEmpty b && isEmpty c && isEmpty d

96+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d, DecidablyEmpty e) => DecidablyEmpty (a, b, c, d, e) where

97+ isEmpty (a, b, c, d, e) = isEmpty a && isEmpty b && isEmpty c && isEmpty d && isEmpty e

98+

99+-- containers

100+

101+instance DecidablyEmpty IntSet.IntSet where

102+ isEmpty = IntSet.null

103+instance DecidablyEmpty (IntMap.IntMap v) where

104+ isEmpty = IntMap.null

105+instance Ord k => DecidablyEmpty (Map.Map k v) where

106+ isEmpty = Map.null

107+instance DecidablyEmpty (Seq.Seq v) where

108+ isEmpty = Seq.null

109+instance Ord k => DecidablyEmpty (Set.Set k) where

110+ isEmpty = Set.null

111+

112+-- dependent-map

113+

114+instance GCompare k => DecidablyEmpty (DMap.DMap k v) where

115+ isEmpty = DMap.null

src/Data/Patch.hs+1−1

@@ -18,7 +18,7 @@ import Data.Functor.Const (Const (..))

1818import Data.Functor.Identity

1919import Data.Map.Monoidal (MonoidalMap)

2020import Data.Proxy

21−#if !MIN_VERSION_base(4,10,0)

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

2222import Data.Semigroup (Semigroup (..))

2323#endif

2424import GHC.Generics

src/Data/Patch/Class.hs+3

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TypeFamilies #-}

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

34module Data.Patch.Class where

56import Data.Functor.Identity

67import Data.Maybe

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

79import Data.Semigroup (Semigroup(..))

10+#endif

811import Data.Proxy

912

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

src/Data/Patch/DMap.hs+9

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE GeneralizedNewtypeDeriving #-}

23{-# LANGUAGE LambdaCase #-}

34{-# LANGUAGE PolyKinds #-}

@@ -5,6 +6,7 @@

56{-# LANGUAGE ScopedTypeVariables #-}

67{-# LANGUAGE StandaloneDeriving #-}

78{-# LANGUAGE TypeFamilies #-}

810-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

911module Data.Patch.DMap where

1012

@@ -18,7 +20,10 @@ import Data.Functor.Constant

1820import Data.Functor.Misc

1921import qualified Data.IntMap as IntMap

2022import qualified Data.Map as Map

23+import Data.Monoid.DecidablyEmpty

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

2125import Data.Semigroup (Semigroup (..))

26+#endif

2227import Data.Some (Some)

2328

2429-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.

@@ -30,6 +35,10 @@ deriving instance GCompare k => Semigroup (PatchDMap k v)

3035

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

3237

38+-- It won't let me derive for some reason

39+instance GCompare k => DecidablyEmpty (PatchDMap k v) where

40+ isEmpty (PatchDMap m) = DMap.null m

41+

3342-- | Apply the insertions or deletions to a given 'DMap'.

3443instance GCompare k => Patch (PatchDMap k v) where

3544 type PatchTarget (PatchDMap k v) = DMap k v

src/Data/Patch/DMapWithMove.hs+8−1

@@ -29,7 +29,10 @@ import Data.GADT.Compare (GEq (..))

2929import Data.GADT.Show (GShow, gshow)

3030import qualified Data.Map as Map

3131import Data.Maybe

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

32+import Data.Monoid.DecidablyEmpty

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

34+import Data.Semigroup (Semigroup (..))

35+#endif

3336import Data.Some (Some(Some))

3437import Data.These

3538

@@ -42,6 +45,10 @@ import Data.These

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

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

4447

48+-- It won't let me derive for some reason

49+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where

50+ isEmpty (PatchDMapWithMove m) = DMap.null m

51+

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

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

4754data NodeInfo k v a = NodeInfo

src/Data/Patch/IntMap.hs+9−6

@@ -1,7 +1,9 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DeriveTraversable #-}

23{-# LANGUAGE FlexibleInstances #-}

34{-# LANGUAGE GeneralizedNewtypeDeriving #-}

45{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE StandaloneDeriving #-}

57{-# LANGUAGE TemplateHaskell #-}

68{-# LANGUAGE TypeFamilies #-}

@@ -13,7 +15,10 @@ import Control.Lens

1315import Data.IntMap.Strict (IntMap)

1416import qualified Data.IntMap.Strict as IntMap

1517import Data.Maybe

16−import Data.Semigroup

18+import Data.Monoid.DecidablyEmpty

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

20+import Data.Semigroup (Semigroup (..))

21+#endif

1722import Data.Patch.Class

1823

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

@@ -21,16 +26,14 @@ import Data.Patch.Class

2126-- and @Nothing@ means delete.

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

2328 deriving ( Show, Read, Eq, Ord

24− , Functor, Foldable, Traversable, Monoid

29+ , Functor, Foldable, Traversable

30+ , Monoid, DecidablyEmpty

2531 )

2632

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

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

2935-- precedence.

30−instance Semigroup (PatchIntMap v) where

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

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

33− stimes = stimesIdempotentMonoid

36+deriving instance Semigroup (PatchIntMap v)

3437

3538makeWrapped ''PatchIntMap

3639

src/Data/Patch/Map.hs+9−8

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DeriveTraversable #-}

23{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

35{-# LANGUAGE LambdaCase #-}

46{-# LANGUAGE MultiParamTypeClasses #-}

57{-# LANGUAGE StandaloneDeriving #-}

@@ -16,7 +18,8 @@ import Control.Lens

1618import Data.Map (Map)

1719import qualified Data.Map as Map

1820import Data.Maybe

19−import Data.Semigroup

21+import Data.Monoid.DecidablyEmpty

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

2023

2124-- | A set of changes to a 'Map'. Any element may be inserted/updated or

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

@@ -24,11 +27,14 @@ import Data.Semigroup

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

2528 deriving ( Show, Read, Eq, Ord

2629 , Foldable, Traversable

30+ , DecidablyEmpty

2731 )

2832

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

3034-- Deletions are unaffected.

3135deriving instance Functor (PatchMap k)

36+-- | The empty 'PatchMap' contains no insertions or deletions

37+deriving instance Ord k => Monoid (PatchMap k v)

3238

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

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

@@ -38,8 +44,6 @@ instance Ord k => Semigroup (PatchMap k v) where

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

3945 stimes = stimesIdempotentMonoid

4046

41−makeWrapped ''PatchMap

42−

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

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

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

@@ -57,11 +61,6 @@ instance TraversableWithIndex k (PatchMap k) where

5761 itraverse = itraversed . Indexed

5862 itraversed = _Wrapped .> itraversed <. traversed

5963

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

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

62− mempty = PatchMap mempty

63− mappend = (<>)

64−

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

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

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

@@ -69,3 +68,5 @@ patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

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

7069patchMapNewElementsMap :: PatchMap k v -> Map k v

7170patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p

71+

72+makeWrapped ''PatchMap

src/Data/Patch/MapWithMove.hs+1−1

@@ -34,7 +34,7 @@ import Data.List

3434import Data.Map (Map)

3535import qualified Data.Map as Map

3636import Data.Proxy

37−#if !MIN_VERSION_base(4,10,0)

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

3838import Data.Semigroup (Semigroup (..))

3939#endif

4040import Data.Traversable (foldMapDefault)

src/Data/Patch/MapWithPatchingMove.hs+33−8

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

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE LambdaCase #-}

@@ -25,7 +26,7 @@ import Data.List

2526import Data.Map (Map)

2627import qualified Data.Map as Map

2728import Data.Maybe

28−#if !MIN_VERSION_base(4,10,0)

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

2930import Data.Semigroup (Semigroup (..))

3031#endif

3132import Data.Monoid.DecidablyEmpty

@@ -46,6 +47,14 @@ deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMa

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

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

4849

50+deriving instance ( Ord k

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

52+ , Semigroup p

53+#endif

54+ , DecidablyEmpty p

55+ , Patch p

56+ ) => DecidablyEmpty (PatchMapWithPatchingMove k p)

57+

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

5059-- and where its old value should go to

5160data NodeInfo k p = NodeInfo

@@ -127,7 +136,13 @@ insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_I

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

128137-- @

129138moveMapKey

130− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p

139+ :: ( DecidablyEmpty p

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

141+ , Semigroup p

142+#endif

143+ , Patch p

144+ )

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

131146moveMapKey src dst

132147 | src == dst = mempty

133148 | otherwise =

@@ -146,7 +161,12 @@ moveMapKey src dst

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

147162-- @

148163swapMapKey

149− :: (DecidablyEmpty p, Patch p)

164+ :: ( DecidablyEmpty p

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

166+ , Semigroup p

167+#endif

168+ , Patch p

169+ )

150170 => Ord k => k -> k -> PatchMapWithPatchingMove k p

151171swapMapKey src dst

152172 | src == dst = mempty

@@ -248,7 +268,7 @@ patchThatChangesMap oldByIndex newByIndex = patch

248268 putRemainingKeys $ Set.delete k fromKs

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

250270 else do

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

271+ (fromK, remainingKeys) <- return . fromMaybe (error "patchThatChangesMap: impossible: fromKs was empty") $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

252272 putRemainingKeys remainingKeys

253273 return $ NodeInfo (From_Move fromK mempty) $ Just undefined

254274 Map.traverseWithKey f newByIndex

@@ -277,14 +297,17 @@ nodeInfoSetTo

277297 :: To k -> NodeInfo k v -> NodeInfo k v

278298nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

279299

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

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

281301data Fixup k v

282302 = Fixup_Delete

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

284304

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

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

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

286307instance ( Ord k

287− , Monoid p

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

309+ , Semigroup p

310+#endif

288311 , DecidablyEmpty p

289312 , Patch p

290313 ) => Semigroup (PatchMapWithPatchingMove k p) where

@@ -343,7 +366,9 @@ instance ( Ord k

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

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

345368instance ( Ord k

346− , Monoid p

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

370+ , Semigroup p

371+#endif

347372 , DecidablyEmpty p

348373 , Patch p

349374 ) => Monoid (PatchMapWithPatchingMove k p) where