patch 0.0.2.0 → 0.0.3.0

raw patch · 11 files changed

+573/−32 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• patch.cabal +3/−1
• src/Data/Monoid/DecidablyEmpty.hs +115/−0
• src/Data/Patch.hs +22/−14
• src/Data/Patch/Class.hs +9/−0
• src/Data/Patch/DMap.hs +9/−0
• 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 +5/−2
• src/Data/Patch/MapWithPatchingMove.hs +378/−0

@@ -1,5 +1,11 @@ # Revision history for patch +## 0.0.3.0++* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.++* Create `DecidablyEmpty` subclass of `Monoid`.+ ## 0.0.2.0  * Consistently provide:

@@ -1,5 +1,5 @@ Name: patch-Version: 0.0.2.0+Version: 0.0.3.0 Synopsis: Infrastructure for writing patches which act on other types. Description:   In this library, a patch is something which can be applied, analogous to a@@ -41,6 +41,7 @@                , witherable >= 0.3 && < 0.3.2    exposed-modules: Data.Functor.Misc+                 , Data.Monoid.DecidablyEmpty                  , Data.Patch                  , Data.Patch.Class                  , Data.Patch.DMap@@ -48,6 +49,7 @@                  , Data.Patch.IntMap                  , Data.Patch.Map                  , Data.Patch.MapWithMove+                 , Data.Patch.MapWithPatchingMove    ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs 

@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++-- TODO upstream somwhere else?+module Data.Monoid.DecidablyEmpty where++import Data.Functor.Identity+import Data.Functor.Const+import Data.Monoid+import Data.Maybe (isNothing)+#if MIN_VERSION_base(4,11,0)+import Data.Ord+#endif+import Data.Proxy+import Data.Semigroup hiding (First, Last)+#if MIN_VERSION_base(4,12,0)+import GHC.Generics+#endif++import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set++import Data.GADT.Compare+import qualified Data.Dependent.Map as DMap++-- | A 'DecidablyEmpty' is one where it can be computed whether or not an+-- arbitrary value is 'mempty'.+--+-- By using this class rather than 'Eq', we avoid unnecessary constraining the+-- contents of 'Functor's. This makes it possible to efficiently combine and/or+-- nest patch maps with 'Eq'-lacking values (e.g. functions) at the leaves.+class Monoid a => DecidablyEmpty a where+  isEmpty :: a -> Bool+  default isEmpty :: Eq a => a -> Bool+  isEmpty = (==) mempty++-- base++instance DecidablyEmpty Ordering+instance DecidablyEmpty ()+instance DecidablyEmpty Any+instance DecidablyEmpty All+-- instance DecidablyEmpty Lifetime+-- instance DecidablyEmpty Event+instance DecidablyEmpty [a] where+  isEmpty = null+instance+#if MIN_VERSION_base(4,11,0)+  Semigroup a+#else+  Monoid a+#endif+  => DecidablyEmpty (Maybe a) where+  isEmpty = isNothing+deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a)+deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a)+deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a)+instance DecidablyEmpty (First a) where+  isEmpty (First a) = isNothing a+instance DecidablyEmpty (Last a) where+  isEmpty (Last a) = isNothing a+deriving instance DecidablyEmpty a => DecidablyEmpty (Identity a)+instance Semigroup a => DecidablyEmpty (Option a) where+  isEmpty (Option a) = isNothing a+deriving instance DecidablyEmpty m => DecidablyEmpty (WrappedMonoid m)+instance (Ord a, Bounded a) => DecidablyEmpty (Max a)+instance (Ord a, Bounded a) => DecidablyEmpty (Min a)+instance DecidablyEmpty (Proxy s)+deriving instance DecidablyEmpty a => DecidablyEmpty (Const a b)+#if MIN_VERSION_base(4,11,0)+deriving instance DecidablyEmpty a => DecidablyEmpty (Down a)+#endif+#if MIN_VERSION_base(4,12,0)+deriving instance DecidablyEmpty p => DecidablyEmpty (Par1 p)+instance DecidablyEmpty (U1 p)+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (Rec1 f p)+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (M1 i c f p)+deriving instance DecidablyEmpty c => DecidablyEmpty (K1 i c p)+instance (DecidablyEmpty (f p), DecidablyEmpty (g p)) => DecidablyEmpty ((f :*: g) p) where+  isEmpty (x :*: y) = isEmpty x && isEmpty y+deriving instance DecidablyEmpty (f (g p)) => DecidablyEmpty ((f :.: g) p)+#endif++instance (DecidablyEmpty a, DecidablyEmpty b) => DecidablyEmpty (a, b) where+  isEmpty (a, b) = isEmpty a && isEmpty b+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c) => DecidablyEmpty (a, b, c) where+  isEmpty (a, b, c) = isEmpty a && isEmpty b && isEmpty c+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d) => DecidablyEmpty (a, b, c, d) where+  isEmpty (a, b, c, d) = isEmpty a && isEmpty b && isEmpty c && isEmpty d+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d, DecidablyEmpty e) => DecidablyEmpty (a, b, c, d, e) where+  isEmpty (a, b, c, d, e) = isEmpty a && isEmpty b && isEmpty c && isEmpty d && isEmpty e++-- containers++instance DecidablyEmpty IntSet.IntSet where+  isEmpty = IntSet.null+instance DecidablyEmpty (IntMap.IntMap v) where+  isEmpty = IntMap.null+instance Ord k => DecidablyEmpty (Map.Map k v) where+  isEmpty = Map.null+instance DecidablyEmpty (Seq.Seq v) where+  isEmpty = Seq.null+instance Ord k => DecidablyEmpty (Set.Set k) where+  isEmpty = Set.null++-- dependent-map++instance GCompare k => DecidablyEmpty (DMap.DMap k v) where+  isEmpty = DMap.null

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}@@ -12,24 +13,31 @@   , module X   ) where +import Control.Applicative+import Data.Functor.Const (Const (..))+import Data.Functor.Identity+import Data.Map.Monoidal (MonoidalMap)+import Data.Proxy+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif+import GHC.Generics+ import Data.Patch.Class as X import Data.Patch.DMap as X hiding (getDeletions)-import Data.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,-                                       patchDMapWithMoveToPatchMapWithMoveWith,-                                       traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,-                                       unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)+import Data.Patch.DMapWithMove as X+  ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove+  , patchDMapWithMoveToPatchMapWithMoveWith+  , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove+  , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith+  ) import Data.Patch.IntMap as X hiding (getDeletions) import Data.Patch.Map as X-import Data.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,-                                      patchMapWithMoveNewElementsMap, unPatchMapWithMove,-                                      unsafePatchMapWithMove)-import Data.Map.Monoidal (MonoidalMap)-import Data.Semigroup (Semigroup (..), (<>))-import GHC.Generics-import Data.Functor.Identity-import Data.Functor.Const-import Data.Proxy-import Control.Applicative+import Data.Patch.MapWithMove as X+  ( PatchMapWithMove, patchMapWithMoveNewElements+  , patchMapWithMoveNewElementsMap, unPatchMapWithMove+  , unsafePatchMapWithMove+  )  -- | A 'Group' is a 'Monoid' where every element has an inverse. class (Semigroup q, Monoid q) => Group q where

@@ -1,10 +1,14 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -- | The interface for types which represent changes made to other types module Data.Patch.Class where  import Data.Functor.Identity import Data.Maybe+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..))+#endif+import Data.Proxy  -- | A 'Patch' type represents a kind of change made to a datastructure. --@@ -24,6 +28,11 @@ instance Patch (Identity a) where   type PatchTarget (Identity a) = a   apply (Identity a) _ = Just a++-- | 'Proxy' can be used as a 'Patch' that does nothing.+instance Patch (Proxy a) where+  type PatchTarget (Proxy a) = a+  apply ~Proxy _ = Nothing  -- | Like '(.)', but composes functions that return patches rather than -- functions that return new values.  The Semigroup instance for patches must

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PolyKinds #-}@@ -5,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}+ -- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions. module Data.Patch.DMap where @@ -18,7 +20,10 @@ import Data.Functor.Misc import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import Data.Monoid.DecidablyEmpty+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..))+#endif import Data.Some (Some)  -- | A set of changes to a 'DMap'.  Any element may be inserted/updated or deleted.@@ -29,6 +34,10 @@ deriving instance GCompare k => Semigroup (PatchDMap k v)  deriving instance GCompare k => Monoid (PatchDMap k v)++-- It won't let me derive for some reason+instance GCompare k => DecidablyEmpty (PatchDMap k v) where+  isEmpty (PatchDMap m) = DMap.null m  -- | Apply the insertions or deletions to a given 'DMap'. instance GCompare k => Patch (PatchDMap k v) where

@@ -29,7 +29,10 @@ import Data.GADT.Show (GShow, gshow) import qualified Data.Map as Map import Data.Maybe-import Data.Semigroup (Semigroup (..), (<>))+import Data.Monoid.DecidablyEmpty+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif import Data.Some (Some(Some)) import Data.These @@ -41,6 +44,10 @@ --     * A key should not move to itself. --     * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@) newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))++-- It won't let me derive for some reason+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where+  isEmpty (PatchDMapWithMove m) = DMap.null m  -- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key -- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.

@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,7 +15,10 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.Maybe-import Data.Semigroup+import Data.Monoid.DecidablyEmpty+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif import Data.Patch.Class  -- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.@@ -21,16 +26,14 @@ -- and @Nothing@ means delete. newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }   deriving ( Show, Read, Eq, Ord-           , Functor, Foldable, Traversable, Monoid+           , Functor, Foldable, Traversable+           , Monoid, DecidablyEmpty            )  -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. -- If the same key is modified by both patches, the one on the left will take -- precedence.-instance Semigroup (PatchIntMap v) where-  PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map-  -- PatchMap is idempotent, so stimes n is id for every n-  stimes = stimesIdempotentMonoid+deriving instance Semigroup (PatchIntMap v)  makeWrapped ''PatchIntMap 

@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-}@@ -16,7 +18,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Semigroup+import Data.Monoid.DecidablyEmpty+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)  -- | A set of changes to a 'Map'.  Any element may be inserted/updated or -- deleted.  Insertions are represented as values wrapped in 'Just', while@@ -24,11 +27,14 @@ newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }   deriving ( Show, Read, Eq, Ord            , Foldable, Traversable+           , DecidablyEmpty            )  -- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert. -- Deletions are unaffected. deriving instance Functor (PatchMap k)+-- | The empty 'PatchMap' contains no insertions or deletions+deriving instance Ord k => Monoid (PatchMap k v)  -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@. -- If the same key is modified by both patches, the one on the left will take@@ -38,8 +44,6 @@   -- PatchMap is idempotent, so stimes n is id for every n   stimes = stimesIdempotentMonoid -makeWrapped ''PatchMap- -- | Apply the insertions or deletions to a given 'Map'. instance Ord k => Patch (PatchMap k v) where   type PatchTarget (PatchMap k v) = Map k v@@ -57,11 +61,6 @@   itraverse = itraversed . Indexed   itraversed = _Wrapped .> itraversed <. traversed --- | The empty 'PatchMap' contains no insertions or deletions-instance Ord k => Monoid (PatchMap k v) where-  mempty = PatchMap mempty-  mappend = (<>)- -- | Returns all the new elements that will be added to the 'Map' patchMapNewElements :: PatchMap k v -> [v] patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p@@ -69,3 +68,5 @@ -- | Returns all the new elements that will be added to the 'Map' patchMapNewElementsMap :: PatchMap k v -> Map k v patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p++makeWrapped ''PatchMap

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -24,7 +25,9 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Semigroup (Semigroup (..), (<>))+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif import qualified Data.Set as Set import Data.These (These(..)) import Data.Tuple@@ -199,7 +202,7 @@                       putRemainingKeys $ Set.delete k fromKs                       return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary                     else do-                      (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here+                      (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                       putRemainingKeys remainingKeys                       return $ NodeInfo (From_Move fromK) $ Just undefined           Map.traverseWithKey f newByIndex

@@ -0,0 +1,378 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to+-- another+module Data.Patch.MapWithPatchingMove where++import Data.Patch.Class++import Control.Arrow+import Control.Lens.TH (makeWrapped)+import Control.Monad.Trans.State+import Data.Foldable+import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif+import Data.Monoid.DecidablyEmpty+import qualified Data.Set as Set+import Data.These (These (..))+import Data.Tuple++-- | Patch a Map with additions, deletions, and moves.  Invariant: If key @k1@+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,+-- and vice versa.  There should never be any unpaired From/To keys.+newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove+  { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'+    unPatchMapWithPatchingMove :: Map k (NodeInfo k p)+  }++deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)+deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)++deriving instance ( Ord k+#if !MIN_VERSION_base(4,11,0)+                  , Semigroup p+#endif+                  , DecidablyEmpty p+                  , Patch p+                  ) => DecidablyEmpty (PatchMapWithPatchingMove k p)++-- | Holds the information about each key: where its new value should come from,+-- and where its old value should go to+data NodeInfo k p = NodeInfo+  { _nodeInfo_from :: !(From k p)+    -- ^ Where do we get the new value for this key?+  , _nodeInfo_to :: !(To k)+    -- ^ If the old value is being kept (i.e. moved rather than deleted or+    -- replaced), where is it going?+  }+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)++bitraverseNodeInfo+  :: Applicative f+  => (k0 -> f k1)+  -> (p0 -> f p1)+  -> (PatchTarget p0 -> f (PatchTarget p1))+  -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)+bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo+  <$> bitraverseFrom fk fp fpt from+  <*> traverse fk to++-- | Describe how a key's new value should be produced+data From k p+   = From_Insert (PatchTarget p) -- ^ Insert the given value here+   | From_Delete -- ^ Delete the existing value, if any, from here+   | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch++bitraverseFrom+  :: Applicative f+  => (k0 -> f k1)+  -> (p0 -> f p1)+  -> (PatchTarget p0 -> f (PatchTarget p1))+  -> From k0 p0 -> f (From k1 p1)+bitraverseFrom fk fp fpt = \case+  From_Insert pt -> From_Insert <$> fpt pt+  From_Delete -> pure From_Delete+  From_Move k p -> From_Move <$> fk k <*> fp p++deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)++-- | Describe where a key's old value will go.  If this is 'Just', that means+-- the key's old value will be moved to the given other key; if it is 'Nothing',+-- that means it will be deleted.+type To = Maybe++-- | Create a 'PatchMapWithPatchingMove', validating it+patchMapWithPatchingMove+  :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)+patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing+  where valid = forwardLinks == backwardLinks+        forwardLinks = Map.mapMaybe _nodeInfo_to m+        backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->+          case _nodeInfo_from p of+            From_Move from _ -> Just (from, to)+            _ -> Nothing++-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'+patchMapWithPatchingMoveInsertAll+  :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p+patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo+  { _nodeInfo_from = From_Insert v+  , _nodeInfo_to = Nothing+  }++-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.+insertMapKey+  :: k -> PatchTarget p -> PatchMapWithPatchingMove k p+insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing++-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:+--+-- @+--     'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))+-- @+moveMapKey+  :: ( DecidablyEmpty p+#if !MIN_VERSION_base(4,11,0)+     , Semigroup p+#endif+     , Patch p+     )+  => Ord k => k -> k -> PatchMapWithPatchingMove k p+moveMapKey src dst+  | src == dst = mempty+  | otherwise =+      PatchMapWithPatchingMove $ Map.fromList+        [ (dst, NodeInfo (From_Move src mempty) Nothing)+        , (src, NodeInfo From_Delete (Just dst))+        ]++-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:+--+-- @+--     let aMay = Map.lookup a map+--         bMay = Map.lookup b map+--     in maybe id (Map.insert a) (bMay `mplus` aMay)+--      . maybe id (Map.insert b) (aMay `mplus` bMay)+--      . Map.delete a . Map.delete b $ map+-- @+swapMapKey+  :: ( DecidablyEmpty p+#if !MIN_VERSION_base(4,11,0)+     , Semigroup p+#endif+     , Patch p+     )+  => Ord k => k -> k -> PatchMapWithPatchingMove k p+swapMapKey src dst+  | src == dst = mempty+  | otherwise =+    PatchMapWithPatchingMove $ Map.fromList+      [ (dst, NodeInfo (From_Move src mempty) (Just src))+      , (src, NodeInfo (From_Move dst mempty) (Just dst))+      ]++-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in+-- the mapping, equivalent to 'Map.delete'.+deleteMapKey+  :: k -> PatchMapWithPatchingMove k v+deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing++-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.+--+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.+unsafePatchMapWithPatchingMove+  :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p+unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove++-- | Apply the insertions, deletions, and moves to a given 'Map'+instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where+  type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)+  -- 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?+  apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)+    where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of+            From_Insert v -> Just v+            From_Move k p -> applyAlways p <$> Map.lookup k old+            From_Delete -> Nothing+          deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of+            From_Delete -> Just ()+            _ -> Nothing++-- | Returns all the new elements that will be added to the 'Map'+patchMapWithPatchingMoveNewElements+  :: PatchMapWithPatchingMove k p -> [PatchTarget p]+patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap++-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.+patchMapWithPatchingMoveNewElementsMap+  :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)+patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p+  where f ni = case _nodeInfo_from ni of+          From_Insert v -> Just v+          From_Move _ _ -> Nothing+          From_Delete -> Nothing++-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort+-- its values using the given ordering function.  The set keys of the 'Map' is+-- not changed.+patchThatSortsMapWith+  :: (Ord k, Monoid p)+  => (PatchTarget p -> PatchTarget p -> Ordering)+  -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p+patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted+  where unsorted = Map.toList m+        sorted = sortBy (cmp `on` snd) unsorted+        f (to, _) (from, _) = if to == from then Nothing else+          Just (from, to)+        reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted+        g (to, _) (from, _) = if to == from then Nothing else+          let Just movingTo = Map.lookup from reverseMapping+          in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)++-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,+-- will produce a 'Map' with the same values as the second 'Map' but with the+-- values sorted with the given ordering function.+patchThatChangesAndSortsMapWith+  :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)+  => (PatchTarget p -> PatchTarget p -> Ordering)+  -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex+  where newList = Map.toList newByIndexUnsorted+        newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList++-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,+-- will produce the second 'Map'.+patchThatChangesMap+  :: (Ord k, Ord (PatchTarget p), Monoid p)+  => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p+patchThatChangesMap oldByIndex newByIndex = patch+  where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex+        (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do+          let f k v = do+                remainingValues <- get+                let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys+                      then Map.delete v remainingValues+                      else Map.insert v remainingKeys remainingValues+                case Map.lookup v remainingValues of+                  Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take+                  Just fromKs ->+                    if k `Set.member` fromKs+                    then do+                      putRemainingKeys $ Set.delete k fromKs+                      return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary+                    else do+                      (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here+                      putRemainingKeys remainingKeys+                      return $ NodeInfo (From_Move fromK mempty) $ Just undefined+          Map.traverseWithKey f newByIndex+        unusedOldKeys = fold unusedValuesByValue+        pointlessMove k = \case+          From_Move k' _ | k == k' -> True+          _ -> False+        keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)+          then Just undefined+          else Nothing+        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++-- | Change the 'From' value of a 'NodeInfo'+nodeInfoMapFrom+  :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }++-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or+-- 'Applicative', 'Monad', etc.) action to get the new value+nodeInfoMapMFrom+  :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni++-- | Set the 'To' field of a 'NodeInfo'+nodeInfoSetTo+  :: To k -> NodeInfo k v -> NodeInfo k v+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }++-- | Helper data structure used for composing patches using the monoid instance.+data Fixup k v+   = Fixup_Delete+   | Fixup_Update (These (From k v) (To k))++-- | Compose patches having the same effect as applying the patches in turn:+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@+instance ( Ord k+#if !MIN_VERSION_base(4,11,0)+         , Semigroup p+#endif+         , DecidablyEmpty p+         , Patch p+         ) => Semigroup (PatchMapWithPatchingMove k p) where+  PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m+    where+      connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb+      h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]+      h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of+        (Just toAfter, From_Move fromBefore p)+          | fromBefore == toAfter && isEmpty p+            -> [(toAfter, Fixup_Delete)]+          | otherwise+            -> [ (toAfter, Fixup_Update (This editBefore))+               , (fromBefore, Fixup_Update (That mToAfter))+               ]+        (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+        (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]+        (Nothing, _) -> []+      mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete+      mergeFixups _ (Fixup_Update a) (Fixup_Update b)+        | This x <- a, That y <- b+        = Fixup_Update $ These x y+        | That y <- a, This x <- b+        = Fixup_Update $ These x y+      mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"+      fixups = Map.fromListWithKey mergeFixups $ concatMap h connections+      combineNodeInfos _ nia nib = NodeInfo+        { _nodeInfo_from = _nodeInfo_from nia+        , _nodeInfo_to = _nodeInfo_to nib+        }+      applyFixup _ ni = \case+        Fixup_Delete -> Nothing+        Fixup_Update u -> Just $ NodeInfo+          { _nodeInfo_from = case _nodeInfo_from ni of+              f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch+                Nothing -> f -- If there's no `from` fixup, just use the "new" `from`+                Just (From_Insert v) -> From_Insert $ applyAlways p' v+                Just From_Delete -> From_Delete+                Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p+              _ -> error "PatchMapWithPatchingMove: fixup for non-move From"+          , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u+          }+      m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups+      getHere :: These a b -> Maybe a+      getHere = \case+        This a -> Just a+        These a _ -> Just a+        That _ -> Nothing+      getThere :: These a b -> Maybe b+      getThere = \case+        This _ -> Nothing+        These _ b -> Just b+        That b -> Just b++--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here+-- | Compose patches having the same effect as applying the patches in turn:+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@+instance ( Ord k+#if !MIN_VERSION_base(4,11,0)+         , Semigroup p+#endif+         , DecidablyEmpty p+         , Patch p+         ) => Monoid (PatchMapWithPatchingMove k p) where+  mempty = PatchMapWithPatchingMove mempty+  mappend = (<>)++makeWrapped ''PatchMapWithPatchingMove