packages feed

patch 0.0.4.0 → 0.0.5.0

raw patch · 9 files changed

+481/−295 lines, 9 filesdep +HUnitdep +hedgehogdep +patchdep ~basedep ~containersdep ~witherable

Dependencies added: HUnit, hedgehog, patch

Dependency ranges changed: base, containers, witherable

Files

ChangeLog.md view
@@ -1,24 +1,35 @@ # Revision history for patch -## 0.0.4.0+## 0.0.5.0 - 2021-12-17 +* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported+  from `Data.Patch` for compatability.++* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.+  Care is taken to make this not a breaking change.+  In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.+  There are complete constructor and field patterns too, and everything is+  exported under the newtype as real constructors and fields would be.++## 0.0.4.0 - 2021-04-20+ * Enable PolyKinds -## 0.0.3.2+## 0.0.3.2 - 2020-11-06  * Update version bounds -## 0.0.3.1+## 0.0.3.1 - 2020-02-05  * Replace `fromJust` with something easier to debug. -## 0.0.3.0+## 0.0.3.0 - 2020-02-05  * Create `PatchMapWithPatchingMove` variant which supports moves with a patch.  * Create `DecidablyEmpty` subclass of `Monoid`. -## 0.0.2.0+## 0.0.2.0 - 2020-01-17  * Consistently provide: @@ -30,16 +41,16 @@    for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`. -## 0.0.1.0+## 0.0.1.0 - 2020-01-09  * Support older GHCs with `split-these` flag.  * Additional instances for the `Group` class for basic types. -## 0.0.0.1+## 0.0.0.1 - 2020-01-08  * Remove unneeded dependencies -## 0.0.0.0+## 0.0.0.0 - 2020-01-08  * Extract patching functionality from Reflex.
patch.cabal view
@@ -1,5 +1,5 @@ Name: patch-Version: 0.0.4.0+Version: 0.0.5.0 Synopsis: Data structures for describing changes to other data structures. Description:   Data structures for describing changes to other data structures.@@ -41,7 +41,7 @@                , lens >= 4.7 && < 5                , semigroupoids >= 4.0 && < 6                , transformers >= 0.5.6.0 && < 0.6-               , witherable >= 0.3 && < 0.4+               , witherable >= 0.3 && < 0.5    exposed-modules: Data.Functor.Misc                  , Data.Monoid.DecidablyEmpty@@ -53,6 +53,7 @@                  , Data.Patch.Map                  , Data.Patch.MapWithMove                  , Data.Patch.MapWithPatchingMove+                 , Data.Semigroup.Additive    ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs   default-extensions: PolyKinds@@ -64,6 +65,19 @@   else     build-depends: these >= 0.4 && <0.9                  , monoidal-containers == 0.4.0.0++test-suite tests+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: tests.hs+  hs-source-dirs: test+  build-depends: base+               , patch+               , containers+               , hedgehog+               , HUnit+  if impl(ghcjs)+    buildable: False  test-suite hlint   default-language: Haskell2010
src/Data/Patch.hs view
@@ -23,6 +23,7 @@ #endif import GHC.Generics +import Data.Semigroup.Additive as X import Data.Patch.Class as X import Data.Patch.DMap as X hiding (getDeletions) import Data.Patch.DMapWithMove as X@@ -45,9 +46,6 @@   (~~) :: q -> q -> q   r ~~ s = r <> negateG s --- | An 'Additive' 'Semigroup' is one where (<>) is commutative-class Semigroup q => Additive q where- -- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type. newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p } @@ -58,19 +56,15 @@ instance (Ord k, Group q) => Group (MonoidalMap k q) where   negateG = fmap negateG -instance (Ord k, Additive q) => Additive (MonoidalMap k q)- -- | Trivial group. instance Group () where   negateG _ = ()   _ ~~ _ = ()-instance Additive ()  -- | Product group.  A Pair of groups gives rise to a group instance (Group a, Group b) => Group (a, b) where   negateG (a, b) = (negateG a, negateG b)   (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)-instance (Additive a, Additive b) => Additive (a, b)  -- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided. -- Base does not define Monoid (Compose f g a) so this is the best we can@@ -78,29 +72,24 @@ instance Group (f (g a)) => Group ((f :.: g) a) where   negateG (Comp1 xs) = Comp1 (negateG xs)   Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)-instance Additive (f (g a)) => Additive ((f :.: g) a)  -- | Product of groups, Functor style. instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where   negateG (a :*: b) = negateG a :*: negateG b   (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)-instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)  -- | Trivial group, Functor style instance Group (Proxy x) where   negateG _ = Proxy   _ ~~ _ = Proxy-instance Additive (Proxy x)  -- | Const lifts groups into a functor. deriving instance Group a => Group (Const a x)-instance Additive a => Additive (Const a x)--- | Ideitnty lifts groups pointwise (at only one point)++-- | Identity lifts groups pointwise (at only one point) deriving instance Group a => Group (Identity a)-instance Additive a => Additive (Identity a)  -- | Functions lift groups pointwise. instance Group b => Group (a -> b) where   negateG f = negateG . f   (~~) = liftA2 (~~)-instance Additive b => Additive (a -> b)
src/Data/Patch/Class.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | The interface for types which represent changes made to other types module Data.Patch.Class where  import Data.Functor.Identity+import Data.Kind (Type) import Data.Maybe #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..))@@ -15,7 +17,7 @@ -- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey -- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@. class Patch p where-  type PatchTarget p :: *+  type PatchTarget p :: Type   -- | Apply the patch @p a@ to the value @a@.  If no change is needed, return   -- 'Nothing'.   apply :: p -> PatchTarget p -> Maybe (PatchTarget p)@@ -30,7 +32,7 @@   apply (Identity a) _ = Just a  -- | 'Proxy' can be used as a 'Patch' that does nothing.-instance Patch (Proxy (a :: *)) where+instance forall (a :: Type). Patch (Proxy a) where   type PatchTarget (Proxy a) = a   apply ~Proxy _ = Nothing
src/Data/Patch/DMapWithMove.hs view
@@ -220,8 +220,8 @@ -- @ --     let aMay = DMap.lookup a dmap --         bMay = DMap.lookup b dmap---     in maybe id (DMap.insert a) (bMay `mplus` aMay)---      . maybe id (DMap.insert b) (aMay `mplus` bMay)+--     in maybe id (DMap.insert a) (bMay <> aMay)+--      . maybe id (DMap.insert b) (aMay <> bMay) --      . DMap.delete a . DMap.delete b $ dmap -- @ swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
src/Data/Patch/MapWithMove.hs view
@@ -2,98 +2,150 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  -- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to -- another-module Data.Patch.MapWithMove where+module Data.Patch.MapWithMove+  ( PatchMapWithMove+    ( PatchMapWithMove+    , unPatchMapWithMove+    , ..+    )+  , patchMapWithMove+  , patchMapWithMoveInsertAll+  , insertMapKey+  , moveMapKey+  , swapMapKey+  , deleteMapKey+  , unsafePatchMapWithMove+  , patchMapWithMoveNewElements+  , patchMapWithMoveNewElementsMap+  , patchThatSortsMapWith+  , patchThatChangesAndSortsMapWith+  , patchThatChangesMap +  -- * Node Info+  , NodeInfo+    ( NodeInfo+    , _nodeInfo_to+    , _nodeInfo_from+    , ..+    )+  , bitraverseNodeInfo+  , nodeInfoMapFrom+  , nodeInfoMapMFrom+  , nodeInfoSetTo++  -- * From+  , From+    ( From_Insert+    , From_Delete+    , From_Move+    , ..+    )+  , bitraverseFrom++  -- * To+  , To+  ) where++import Data.Coerce+import Data.Kind (Type) import Data.Patch.Class+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym -import Control.Arrow-import Control.Lens hiding (from, to)-import Control.Monad.Trans.State-import Data.Foldable-import Data.Function+import Control.Lens import Data.List import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe+import Data.Proxy #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+import Data.Traversable (foldMapDefault)  -- | 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 PatchMapWithMove k v = PatchMapWithMove-  { -- | Extract the internal representation of the 'PatchMapWithMove'-    unPatchMapWithMove :: Map k (NodeInfo k v)+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'+  { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'+    unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)   }   deriving ( Show, Read, Eq, Ord-           , Functor, Foldable, Traversable+-- Haddock cannot handle documentation here before GHC 8.6+           ,+#if __GLASGOW_HASKELL__ >= 806+             -- | Compose patches having the same effect as applying the+             -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .+             -- 'applyAlways' q@+#endif+             Semigroup+           , Monoid            ) --- | Holds the information about each key: where its new value should come from,--- and where its old value should go to-data NodeInfo k v = NodeInfo-  { _nodeInfo_from :: !(From k v)-    -- ^ 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 (Show, Read, Eq, Ord, Functor, Foldable, Traversable)+pattern Coerce :: Coercible a b => a -> b+pattern Coerce x <- (coerce -> x)+  where Coerce x = coerce x --- | Describe how a key's new value should be produced-data From k v-   = From_Insert v -- ^ Insert the given value here-   | From_Delete -- ^ Delete the existing value, if any, from here-   | From_Move !k -- ^ Move the value here from the given key-   deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)+{-# COMPLETE PatchMapWithMove #-}+pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v+-- | Extract the representation of the 'PatchMapWithMove' as a map of+-- 'NodeInfo'.+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)+pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove)) --- | 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+_PatchMapWithMove+  :: Iso+       (PatchMapWithMove k0 v0)+       (PatchMapWithMove k1 v1)+       (Map k0 (NodeInfo k0 v0))+       (Map k1 (NodeInfo k1 v1))+_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove -makeWrapped ''PatchMapWithMove+instance Functor (PatchMapWithMove k) where+  fmap f = runIdentity . traverse (Identity . f) +instance Foldable (PatchMapWithMove k) where+  foldMap = foldMapDefault++instance Traversable (PatchMapWithMove k) where+  traverse =+    _PatchMapWithMove .+    traverse .+    traverse+ instance FunctorWithIndex k (PatchMapWithMove k) instance FoldableWithIndex k (PatchMapWithMove k) instance TraversableWithIndex k (PatchMapWithMove k) where   itraverse = itraversed . Indexed-  itraversed = _Wrapped .> itraversed <. traversed+  itraversed =+    _PatchMapWithMove .>+    itraversed <.+    traverse  -- | Create a 'PatchMapWithMove', validating it patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)-patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing-  where valid = forwardLinks == backwardLinks-        forwardLinks = Map.mapMaybe _nodeInfo_to m-        backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->-          case _nodeInfo_from v of-            From_Move from -> Just (from, to)-            _ -> Nothing+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce  -- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map' patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v-patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo-  { _nodeInfo_from = From_Insert v-  , _nodeInfo_to = Nothing-  }+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll  -- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'. insertMapKey :: k -> v -> PatchMapWithMove k v-insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v  -- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to: --@@ -101,84 +153,53 @@ --     'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map)) -- @ moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v-moveMapKey src dst-  | src == dst = mempty-  | otherwise =-      PatchMapWithMove $ Map.fromList-        [ (dst, NodeInfo (From_Move src) Nothing)-        , (src, NodeInfo From_Delete (Just dst))-        ]+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst  -- |Make a @'PatchMapWithMove' k v@ 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)+--     in maybe id (Map.insert a) (bMay <> aMay)+--      . maybe id (Map.insert b) (aMay <> bMay) --      . Map.delete a . Map.delete b $ map -- @ swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v-swapMapKey src dst-  | src == dst = mempty-  | otherwise =-    PatchMapWithMove $ Map.fromList-      [ (dst, NodeInfo (From_Move src) (Just src))-      , (src, NodeInfo (From_Move dst) (Just dst))-      ]+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst  -- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'. deleteMapKey :: k -> PatchMapWithMove k v-deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey  -- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants. -- -- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked. unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v-unsafePatchMapWithMove = PatchMapWithMove+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove  -- | Apply the insertions, deletions, and moves to a given 'Map' instance Ord k => Patch (PatchMapWithMove k v) where   type PatchTarget (PatchMapWithMove k v) = Map k v-  apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?-    where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of-            From_Insert v -> Just v-            From_Move k -> Map.lookup k old-            From_Delete -> Nothing-          deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of-            From_Delete -> Just ()-            _ -> Nothing+  apply (PatchMapWithMove' p) = apply p  -- | Returns all the new elements that will be added to the 'Map'. patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]-patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'  -- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@. patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v-patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p-  where f ni = case _nodeInfo_from ni of-          From_Insert v -> Just v-          From_Move _ -> Nothing-          From_Delete -> Nothing+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'  -- | Create a 'PatchMapWithMove' 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 => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v-patchThatSortsMapWith cmp m = PatchMapWithMove $ 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 to reverseMapping-          in Just (to, NodeInfo (From_Move from) $ Just movingTo)+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp  -- | Create a 'PatchMapWithMove' 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 v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex   where newList = Map.toList newByIndexUnsorted         newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList@@ -186,104 +207,106 @@ -- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, -- will produce the second 'Map'. patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v-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) $ Just undefined -- There's an existing value, and it's here, so no patch necessary-                    else do-                      (fromK, remainingKeys) <- return $-                        fromMaybe (error "PatchMapWithMove.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-        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 = 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+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $+  PM.patchThatChangesMap oldByIndex newByIndex +--+-- NodeInfo+--++-- | Holds the information about each key: where its new value should come from,+-- and where its old value should go to+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }++deriving instance (Show k, Show p) => Show (NodeInfo k p)+deriving instance (Read k, Read p) => Read (NodeInfo k p)+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)++{-# COMPLETE NodeInfo #-}+pattern NodeInfo :: To k -> From k v -> NodeInfo k v+_nodeInfo_to :: NodeInfo k v -> To k+_nodeInfo_from :: NodeInfo k v -> From k v+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'+  PM.NodeInfo+    { PM._nodeInfo_to = _nodeInfo_to+    , PM._nodeInfo_from = Coerce _nodeInfo_from+    }++_NodeInfo+  :: Iso+       (NodeInfo k0 v0)+       (NodeInfo k1 v1)+       (PM.NodeInfo k0 (Proxy v0))+       (PM.NodeInfo k1 (Proxy v1))+_NodeInfo = iso unNodeInfo' NodeInfo'++instance Functor (NodeInfo k) where+  fmap f = runIdentity . traverse (Identity . f)++instance Foldable (NodeInfo k) where+  foldMap = foldMapDefault++instance Traversable (NodeInfo k) where+  traverse = bitraverseNodeInfo pure++bitraverseNodeInfo+  :: Applicative f+  => (k0 -> f k1)+  -> (v0 -> f v1)+  -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)+bitraverseNodeInfo fk fv = fmap NodeInfo'+  . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv+  . coerce+ -- | 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 }+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')  -- | 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+nodeInfoMapMFrom+  :: Functor f+  => (From k v -> f (From k v))+  -> NodeInfo k v -> f (NodeInfo k v)+nodeInfoMapMFrom f = fmap NodeInfo'+  . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')+  . coerce  -- | Set the 'To' field of a 'NodeInfo' nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v-nodeInfoSetTo to ni = ni { _nodeInfo_to = to }+nodeInfoSetTo = coerce . PM.nodeInfoSetTo --- |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))+--+-- From+-- --- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@-instance Ord k => Semigroup (PatchMapWithMove k v) where-  PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m-    where-      connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb-      h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]-      h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of-        (Just toAfter, From_Move fromBefore)-          | fromBefore == toAfter-            -> [(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 "PatchMapWithMove: 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 = fromMaybe (_nodeInfo_from ni) $ getHere u-          , _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+-- | Describe how a key's new value should be produced+newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) } ---TODO: Figure out how to implement this in terms of PatchDMapWithMove 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 => Monoid (PatchMapWithMove k v) where-  mempty = PatchMapWithMove mempty-  mappend = (<>)+{-# COMPLETE From_Insert, From_Delete, From_Move #-}++-- | Insert the given value here+pattern From_Insert :: v -> From k v+pattern From_Insert v = From' (PM.From_Insert v)++-- | Delete the existing value, if any, from here+pattern From_Delete :: From k v+pattern From_Delete = From' PM.From_Delete++-- | Move the value here from the given key+pattern From_Move :: k -> From k v+pattern From_Move k = From' (PM.From_Move k Proxy)++bitraverseFrom+  :: Applicative f+  => (k0 -> f k1)+  -> (v0 -> f v1)+  -> From k0 v0 -> f (From k1 v1)+bitraverseFrom fk fv = fmap From'+  . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv+  . coerce++makeWrapped ''PatchMapWithMove+makeWrapped ''NodeInfo+makeWrapped ''From
src/Data/Patch/MapWithPatchingMove.hs view
@@ -13,14 +13,45 @@  -- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to -- another-module Data.Patch.MapWithPatchingMove where+module Data.Patch.MapWithPatchingMove+  ( PatchMapWithPatchingMove (..)+  , patchMapWithPatchingMove+  , patchMapWithPatchingMoveInsertAll+  , insertMapKey+  , moveMapKey+  , swapMapKey+  , deleteMapKey+  , unsafePatchMapWithPatchingMove+  , patchMapWithPatchingMoveNewElements+  , patchMapWithPatchingMoveNewElementsMap+  , patchThatSortsMapWith+  , patchThatChangesAndSortsMapWith+  , patchThatChangesMap +  -- * Node Info+  , NodeInfo (..)+  , bitraverseNodeInfo+  , nodeInfoMapFrom+  , nodeInfoMapMFrom+  , nodeInfoSetTo++  -- * From+  , From(..)+  , bitraverseFrom++  -- * To+  , To++  -- TODO internals module+  , Fixup (..)+  ) where+ import Data.Patch.Class -import Control.Arrow+import Control.Lens hiding (from, to) import Control.Lens.TH (makeWrapped)-import Control.Monad.Trans.State-import Data.Foldable+import Data.Align (align)+import Data.Foldable (toList) import Data.Function import Data.List import Data.Map (Map)@@ -30,9 +61,9 @@ import Data.Semigroup (Semigroup (..)) #endif import Data.Monoid.DecidablyEmpty+import Data.Set (Set) 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@,@@ -55,57 +86,6 @@                   , 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)@@ -156,8 +136,8 @@ -- @ --     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)+--     in maybe id (Map.insert a) (bMay <> aMay)+--      . maybe id (Map.insert b) (aMay <> bMay) --      . Map.delete a . Map.delete b $ map -- @ swapMapKey@@ -249,40 +229,71 @@  -- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided, -- will produce the second 'Map'.+-- Note: this will never produce a patch on a value. patchThatChangesMap-  :: (Ord k, Ord (PatchTarget p), Monoid p)+  :: forall k p+  .  (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 $-                        fromMaybe (error "PatchMapWithPatchingMove.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 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+  where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)+        invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList+        -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function+        unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'+        unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")+        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))+        unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)+        -- Generate patch info for a single value+        -- Keys that are found in both the old and new sets will not be patched+        -- 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+        -- 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+        patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))+        patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case+          This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it+          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+          These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)+        -- Run patchSingleValue on a These.  Missing old or new sets are considered empty+        patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))+        patchSingleValueThese v = \case+          This oldKeys -> patchSingleValue v oldKeys mempty+          That newKeys -> patchSingleValue v mempty newKeys+          These oldKeys newKeys -> patchSingleValue v oldKeys newKeys+        -- Generate froms and tos for all values, then merge them together+        (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)+        patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case+          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.+          That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted+          These from to -> NodeInfo from to +--+-- NodeInfo+--++-- | 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)++-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of+-- the type families here, this doesn't it any bi- or tri-traversal class.+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+ -- | Change the 'From' value of a 'NodeInfo' nodeInfoMapFrom   :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v@@ -298,6 +309,47 @@ nodeInfoSetTo   :: To k -> NodeInfo k v -> NodeInfo k v nodeInfoSetTo to ni = ni { _nodeInfo_to = to }++--+-- From+--++-- | 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++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)++-- | Traverse the 'From' over the key, patch, and patch target. Because of+-- the type families here, this doesn't it any bi- or tri-traversal class.+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++--+-- To+--++-- | 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++--+-- Fixup+--  -- | Helper data structure used for composing patches using the monoid instance. data Fixup k v
+ src/Data/Semigroup/Additive.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module:+--   Data.Semigroup.Additive+-- Description:+--   This module defines a class for commutative semigroups, until it is moved+--   to another library.+module Data.Semigroup.Additive+  ( Additive+  ) where++import Data.Functor.Const (Const (..))+import Data.Functor.Identity+-- For base-orphans, TODO don't cheat.+import Data.Map.Monoidal ()+import Data.Proxy+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif+import GHC.Generics++-- | An 'Additive' 'Semigroup' is one where (<>) is commutative+class Semigroup q => Additive q where++-- | Trivial additive semigroup.+instance Additive ()++-- | Product additive semigroup.+-- A Pair of additive semigroups gives rise to a additive semigroup+instance (Additive a, Additive b) => Additive (a, b)++-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.+-- Base does not define Monoid (Compose f g a) so this is the best we can+-- really do for functor composition.+instance Additive (f (g a)) => Additive ((f :.: g) a)++-- | Product of additive semigroups, Functor style.+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)++-- | Trivial additive semigroup, Functor style+instance Additive (Proxy x)++-- | Const lifts additive semigroups into a functor.+instance Additive a => Additive (Const a x)++-- | Identity lifts additive semigroups pointwise (at only one point)+instance Additive a => Additive (Identity a)++-- | Functions lift additive semigroups pointwise.+instance Additive b => Additive (a -> b)
+ test/tests.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)+import Data.Patch ( Patch(apply) )+import Data.Patch.MapWithMove ( patchThatChangesMap )+import Data.Map as Map ( Map, fromList, singleton )+import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))+import Hedgehog.Gen as Gen ( int )+import Hedgehog.Range as Range ( linear )+import Control.Monad (replicateM)+import System.Exit (exitFailure, exitSuccess)+import Data.Sequence as Seq ( foldMapWithIndex, replicateM )++main :: IO ()+main = do+   counts <- runTestTT $ test [+      "Simple Move" ~: (do+         let mapBefore = Map.fromList [(0,1)]+             mapAfter = Map.fromList [(0,0),(1,1)]+             patch = patchThatChangesMap mapBefore mapAfter+             afterPatch = apply patch mapBefore+         assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),+      "Property Checks" ~: propertyChecks+    ]+   if errors counts + failures counts == 0 then exitSuccess else exitFailure++propertyChecks :: IO Bool+propertyChecks = checkParallel $$(discover)++prop_patchThatChangesMap :: Property+prop_patchThatChangesMap = property $ do+   mapBefore <- makeRandomIntMap+   mapAfter <- makeRandomIntMap+   let patch = patchThatChangesMap mapBefore mapAfter+   Just mapAfter === apply patch mapBefore++makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)+makeRandomIntMap = do+   let genNum = Gen.int (Range.linear 0 100)+   length <- forAll genNum+   listOfNumbers <- forAll $ Seq.replicateM length genNum+   pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers