git.iko.soy/patch
on develop help sign in
Merge pull request #26 from reflex-frp/fix-patchThatChangesMap
755886bJohn Ericson
patch.cabal+13
compare with develop
unifiedsplit
@@ -65,6 +65,19 @@ library
65 build-depends: these >= 0.4 && <0.9
65 build-depends: these >= 0.4 && <0.9
66 , monoidal-containers == 0.4.0.0
66 , monoidal-containers == 0.4.0.0
67
67
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+
68test-suite hlint
81test-suite hlint
69 default-language: Haskell2010
82 default-language: Haskell2010
70 type: exitcode-stdio-1.0
83 type: exitcode-stdio-1.0
src/Data/Patch/MapWithMove.hs+31−33
@@ -16,9 +16,8 @@ module Data.Patch.MapWithMove where
16
16
17import Data.Patch.Class
17import Data.Patch.Class
18
18
19−import Control.Arrow
20import Control.Lens hiding (from, to)
19import Control.Lens hiding (from, to)
21−import Control.Monad.Trans.State
20+import Data.Align (align)
22import Data.Foldable
21import Data.Foldable
23import Data.Function
22import Data.Function
24import Data.List
23import Data.List
@@ -28,9 +27,9 @@ import Data.Maybe
28#if !MIN_VERSION_base(4,11,0)
27#if !MIN_VERSION_base(4,11,0)
29import Data.Semigroup (Semigroup (..))
28import Data.Semigroup (Semigroup (..))
30#endif
29#endif
30+import Data.Set (Set)
31import qualified Data.Set as Set
31import qualified Data.Set as Set
32import Data.These (These(..))
32import Data.These (These(..))
33−import Data.Tuple
34
33
35-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
34-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
36-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
35-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -185,37 +184,36 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
185
184
186-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
185-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
187-- will produce the second 'Map'.
186-- 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
189patchThatChangesMap oldByIndex newByIndex = patch
188patchThatChangesMap oldByIndex newByIndex = patch
190− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
189+ where invert :: Map k v -> Map v (Set k)
191− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
190+ invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
192− let f k v = do
191+ -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
193− remainingValues <- get
192+ unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
194− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
193+ unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
195− then Map.delete v remainingValues
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))
196− else Map.insert v remainingKeys remainingValues
195+ unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
197− case Map.lookup v remainingValues of
196+ -- Generate patch info for a single value
198− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
197+ -- Keys that are found in both the old and new sets will not be patched
199− Just fromKs ->
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
200− if k `Set.member` fromKs
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
201− then do
200+ patchSingleValue :: v -> Set k -> Set k -> (Map k (From k v), Map k (To k))
202− putRemainingKeys $ Set.delete k fromKs
201+ patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
203− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
202+ This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
204− else do
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
205− (fromK, remainingKeys) <- return $
204+ These oldK newK -> (Map.singleton newK $ From_Move oldK, Map.singleton oldK $ Just newK)
206− fromMaybe (error "PatchMapWithMove.patchThatChangesMap: impossible: fromKs was empty") $
205+ -- Run patchSingleValue on a These. Missing old or new sets are considered empty
207− Set.minView fromKs -- There's an existing value, but it's not here; move it here
206+ patchSingleValueThese :: v -> These (Set k) (Set k) -> (Map k (From k v), Map k (To k))
208− putRemainingKeys remainingKeys
207+ patchSingleValueThese v = \case
209− return $ NodeInfo (From_Move fromK) $ Just undefined
208+ This oldKeys -> patchSingleValue v oldKeys mempty
210− Map.traverseWithKey f newByIndex
209+ That newKeys -> patchSingleValue v mempty newKeys
211− unusedOldKeys = fold unusedValuesByValue
210+ These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
212− pointlessMove k = \case
211+ -- Generate froms and tos for all values, then merge them together
213− From_Move k' | k == k' -> True
212+ (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
214− _ -> False
213+ patch = unsafePatchMapWithMove $ align froms tos <&> \case
215− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
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.
216− then Just undefined
215+ That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
217− else Nothing
216+ These from to -> NodeInfo from to
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
219
217
220-- | Change the 'From' value of a 'NodeInfo'
218-- | Change the 'From' value of a 'NodeInfo'
221nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
219nodeInfoMapFrom :: (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
17
17
18import Data.Patch.Class
18import Data.Patch.Class
19
19
20−import Control.Arrow
20+import Control.Lens hiding (from, to)
21import Control.Lens.TH (makeWrapped)
21import Control.Lens.TH (makeWrapped)
22−import Control.Monad.Trans.State
23−import Data.Foldable
24import Data.Function
22import Data.Function
25import Data.List
23import Data.List
26import Data.Map (Map)
24import Data.Map (Map)
@@ -30,9 +28,9 @@ import Data.Maybe
30import Data.Semigroup (Semigroup (..))
28import Data.Semigroup (Semigroup (..))
31#endif
29#endif
32import Data.Monoid.DecidablyEmpty
30import Data.Monoid.DecidablyEmpty
31+import Data.Patch.MapWithMove (PatchMapWithMove (..))
33−import qualified Data.Set as Set
32+import qualified Data.Patch.MapWithMove as MapWithMove
34import Data.These (These (..))
33import Data.These (These (..))
35−import Data.Tuple
36
34
37-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
35-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
38-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
36-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -249,39 +247,20 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
249
247
250-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
248-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251-- will produce the second 'Map'.
249-- will produce the second 'Map'.
250+-- Note: this will never produce a patch on a value.
252patchThatChangesMap
251patchThatChangesMap
253 :: (Ord k, Ord (PatchTarget p), Monoid p)
252 :: (Ord k, Ord (PatchTarget p), Monoid p)
254 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
253 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
255−patchThatChangesMap oldByIndex newByIndex = patch
254+patchThatChangesMap oldByIndex newByIndex = fromMapWithMove $ MapWithMove.patchThatChangesMap oldByIndex newByIndex
256− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
255+
257− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
256+fromMapWithMove :: Monoid p => PatchMapWithMove k (PatchTarget p) -> PatchMapWithPatchingMove k p
258− let f k v = do
257+fromMapWithMove p = PatchMapWithPatchingMove $ unPatchMapWithMove p <&> \n -> NodeInfo
259− remainingValues <- get
258+ { _nodeInfo_from = case MapWithMove._nodeInfo_from n of
260− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
259+ MapWithMove.From_Insert v -> From_Insert v
261− then Map.delete v remainingValues
260+ MapWithMove.From_Delete -> From_Delete
262− else Map.insert v remainingKeys remainingValues
261+ MapWithMove.From_Move k -> From_Move k mempty
263− case Map.lookup v remainingValues of
262+ , _nodeInfo_to = MapWithMove._nodeInfo_to n
264− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
263+ }
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
285
264
286-- | Change the 'From' value of a 'NodeInfo'
265-- | Change the 'From' value of a 'NodeInfo'
287nodeInfoMapFrom
266nodeInfoMapFrom
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