git.iko.soy/patch
on develop help sign in
Merge pull request #26 from reflex-frp/fix-patchThatChangesMap

Rewrite patchThatChangesMap

commit755886bb3fd721ec3f6cfe1a3a5ec0ac576c6a16 authorJohn Ericson <John.Ericson@Obsidian.Systems> dateSat 22 May 2021, 10:10 (5 years ago) parent68cf3212cabd50
4 files changed+101−68
compare with develop
unifiedsplit
patch.cabal+13 src/Data/Patch/MapWithMove.hs+31−33 src/Data/Patch/MapWithPatchingMove.hs+14−35 test/tests.hs+43
patch.cabal+13
@@ -65,6 +65,19 @@ library
6565 build-depends: these >= 0.4 && <0.9
6666 , monoidal-containers == 0.4.0.0
6767
68+test-suite tests
69+ default-language: Haskell2010
70+ type: exitcode-stdio-1.0
71+ main-is: tests.hs
72+ hs-source-dirs: test
73+ build-depends: base
74+ , patch
75+ , containers
76+ , hedgehog
77+ , HUnit
78+ if impl(ghcjs)
79+ buildable: False
80+
6881test-suite hlint
6982 default-language: Haskell2010
7083 type: exitcode-stdio-1.0
src/Data/Patch/MapWithMove.hs+31−33
@@ -16,9 +16,8 @@ module Data.Patch.MapWithMove where
1616
1717import Data.Patch.Class
1818
19−import Control.Arrow
2019import Control.Lens hiding (from, to)
21−import Control.Monad.Trans.State
20+import Data.Align (align)
2221import Data.Foldable
2322import Data.Function
2423import Data.List
@@ -28,9 +27,9 @@ import Data.Maybe
2827#if !MIN_VERSION_base(4,11,0)
2928import Data.Semigroup (Semigroup (..))
3029#endif
30+import Data.Set (Set)
3131import qualified Data.Set as Set
3232import Data.These (These(..))
33−import Data.Tuple
3433
3534-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3635-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -185,37 +184,36 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
185184
186185-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
187186-- will produce the second 'Map'.
188−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
187+patchThatChangesMap :: forall k v. (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
189188patchThatChangesMap oldByIndex newByIndex = patch
190− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
191− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
192− let f k v = do
193− remainingValues <- get
194− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
195− then Map.delete v remainingValues
196− else Map.insert v remainingKeys remainingValues
197− case Map.lookup v remainingValues of
198− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
199− Just fromKs ->
200− if k `Set.member` fromKs
201− then do
202− putRemainingKeys $ Set.delete k fromKs
203− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
204− else do
205− (fromK, remainingKeys) <- return $
206− fromMaybe (error "PatchMapWithMove.patchThatChangesMap: impossible: fromKs was empty") $
207− Set.minView fromKs -- There's an existing value, but it's not here; move it here
208− putRemainingKeys remainingKeys
209− return $ NodeInfo (From_Move fromK) $ Just undefined
210− Map.traverseWithKey f newByIndex
211− unusedOldKeys = fold unusedValuesByValue
212− pointlessMove k = \case
213− From_Move k' | k == k' -> True
214− _ -> False
215− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
216− then Just undefined
217− else Nothing
218− 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
189+ where invert :: Map k v -> Map v (Set k)
190+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
191+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
192+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
193+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
194+ 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))
195+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
196+ -- Generate patch info for a single value
197+ -- Keys that are found in both the old and new sets will not be patched
198+ -- 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
199+ -- 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
200+ patchSingleValue :: v -> Set k -> Set k -> (Map k (From k v), Map k (To k))
201+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
202+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
203+ 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
204+ These oldK newK -> (Map.singleton newK $ From_Move oldK, Map.singleton oldK $ Just newK)
205+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
206+ patchSingleValueThese :: v -> These (Set k) (Set k) -> (Map k (From k v), Map k (To k))
207+ patchSingleValueThese v = \case
208+ This oldKeys -> patchSingleValue v oldKeys mempty
209+ That newKeys -> patchSingleValue v mempty newKeys
210+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
211+ -- Generate froms and tos for all values, then merge them together
212+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
213+ patch = unsafePatchMapWithMove $ align froms tos <&> \case
214+ 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.
215+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
216+ These from to -> NodeInfo from to
219217
220218-- | Change the 'From' value of a 'NodeInfo'
221219nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
src/Data/Patch/MapWithPatchingMove.hs+14−35
@@ -17,10 +17,8 @@ module Data.Patch.MapWithPatchingMove where
1717
1818import Data.Patch.Class
1919
20−import Control.Arrow
20+import Control.Lens hiding (from, to)
2121import Control.Lens.TH (makeWrapped)
22−import Control.Monad.Trans.State
23−import Data.Foldable
2422import Data.Function
2523import Data.List
2624import Data.Map (Map)
@@ -30,9 +28,9 @@ import Data.Maybe
3028import Data.Semigroup (Semigroup (..))
3129#endif
3230import Data.Monoid.DecidablyEmpty
33−import qualified Data.Set as Set
31+import Data.Patch.MapWithMove (PatchMapWithMove (..))
32+import qualified Data.Patch.MapWithMove as MapWithMove
3433import Data.These (These (..))
35−import Data.Tuple
3634
3735-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3836-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -249,39 +247,20 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
249247
250248-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251249-- will produce the second 'Map'.
250+-- Note: this will never produce a patch on a value.
252251patchThatChangesMap
253252 :: (Ord k, Ord (PatchTarget p), Monoid p)
254253 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
255−patchThatChangesMap oldByIndex newByIndex = patch
256− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
257− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
258− let f k v = do
259− remainingValues <- get
260− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
261− then Map.delete v remainingValues
262− else Map.insert v remainingKeys remainingValues
263− case Map.lookup v remainingValues of
264− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
265− Just fromKs ->
266− if k `Set.member` fromKs
267− then do
268− putRemainingKeys $ Set.delete k fromKs
269− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
270− else do
271− (fromK, remainingKeys) <- return $
272− fromMaybe (error "PatchMapWithPatchingMove.patchThatChangesMap: impossible: fromKs was empty") $
273− Set.minView fromKs -- There's an existing value, but it's not here; move it here
274− putRemainingKeys remainingKeys
275− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
276− Map.traverseWithKey f newByIndex
277− unusedOldKeys = fold unusedValuesByValue
278− pointlessMove k = \case
279− From_Move k' _ | k == k' -> True
280− _ -> False
281− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
282− then Just undefined
283− else Nothing
284− 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
254+patchThatChangesMap oldByIndex newByIndex = fromMapWithMove $ MapWithMove.patchThatChangesMap oldByIndex newByIndex
255+
256+fromMapWithMove :: Monoid p => PatchMapWithMove k (PatchTarget p) -> PatchMapWithPatchingMove k p
257+fromMapWithMove p = PatchMapWithPatchingMove $ unPatchMapWithMove p <&> \n -> NodeInfo
258+ { _nodeInfo_from = case MapWithMove._nodeInfo_from n of
259+ MapWithMove.From_Insert v -> From_Insert v
260+ MapWithMove.From_Delete -> From_Delete
261+ MapWithMove.From_Move k -> From_Move k mempty
262+ , _nodeInfo_to = MapWithMove._nodeInfo_to n
263+ }
285264
286265-- | Change the 'From' value of a 'NodeInfo'
287266nodeInfoMapFrom
test/tests.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+module Main where
3+
4+import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)
5+import Data.Patch ( Patch(apply) )
6+import Data.Patch.MapWithMove ( patchThatChangesMap )
7+import Data.Map as Map ( Map, fromList, singleton )
8+import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))
9+import Hedgehog.Gen as Gen ( int )
10+import Hedgehog.Range as Range ( linear )
11+import Control.Monad (replicateM)
12+import System.Exit (exitFailure, exitSuccess)
13+import Data.Sequence as Seq ( foldMapWithIndex, replicateM )
14+
15+main :: IO ()
16+main = do
17+ counts <- runTestTT $ test [
18+ "Simple Move" ~: (do
19+ let mapBefore = Map.fromList [(0,1)]
20+ mapAfter = Map.fromList [(0,0),(1,1)]
21+ patch = patchThatChangesMap mapBefore mapAfter
22+ afterPatch = apply patch mapBefore
23+ assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),
24+ "Property Checks" ~: propertyChecks
25+ ]
26+ if errors counts + failures counts == 0 then exitSuccess else exitFailure
27+
28+propertyChecks :: IO Bool
29+propertyChecks = checkParallel $$(discover)
30+
31+prop_patchThatChangesMap :: Property
32+prop_patchThatChangesMap = property $ do
33+ mapBefore <- makeRandomIntMap
34+ mapAfter <- makeRandomIntMap
35+ let patch = patchThatChangesMap mapBefore mapAfter
36+ Just mapAfter === apply patch mapBefore
37+
38+makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)
39+makeRandomIntMap = do
40+ let genNum = Gen.int (Range.linear 0 100)
41+ length <- forAll genNum
42+ listOfNumbers <- forAll $ Seq.replicateM length genNum
43+ pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers