[darcs-users] [patch16] Bump the hashed-storage dependency to >=... (and 1 more)
Petr Ročkai
me at mornfall.net
Tue Oct 27 18:29:38 UTC 2009
New submission from Petr Ročkai <me at mornfall.net>:
[Re-send to get picked up by the patch tracker.]
Hi,
this is a "good to go" (pending review) patch for the whatsnew --look-for-adds
performance problem. The reviewer may want to check out the related
hashed-storage changes, pasted as a unified diff below.
Yours,
Petr.
Sun Oct 25 15:35:07 CET 2009 Petr Rockai <me at mornfall.net>
* Bump the hashed-storage dependency to >= 0.4.1.
Sun Oct 25 15:35:36 CET 2009 Petr Rockai <me at mornfall.net>
* A vastly more efficient implementation of LookForAdds.
## The related hashed-storage diff follows, for reviewer's convenience.
Sun Oct 25 15:27:32 CET 2009 Petr Rockai <me at mornfall.net>
* More sophisticated QC for overlay.
Sun Oct 25 15:11:41 CET 2009 Petr Rockai <me at mornfall.net>
* Improve the shape comparison operators in Test.
Sun Oct 25 14:53:30 CET 2009 Petr Rockai <me at mornfall.net>
* Document and somewhat re-formulate overlay (in Tree).
Sun Oct 25 14:50:25 CET 2009 Petr Rockai <me at mornfall.net>
* Implement basic QC for Tree overlay.
Tue Oct 20 17:12:37 CEST 2009 Petr Rockai <me at mornfall.net>
* Implement a rudimentary "overlay" Tree operation.
diff -rN -u -p old-hashed-storage/Storage/Hashed/Test.hs new-hashed-storage/Storage/Hashed/Test.hs
--- old-hashed-storage/Storage/Hashed/Test.hs 2009-10-25 15:41:04.000000000 +0100
+++ new-hashed-storage/Storage/Hashed/Test.hs 2009-10-25 15:41:04.000000000 +0100
@@ -173,13 +173,15 @@ tree = [ testCase "modifyTree" check_mod
, testCase "expandPath" check_expand_path
, testCase "diffTrees" check_diffTrees
, testCase "diffTrees identical" check_diffTrees_ident
- , testProperty "treeEq" prop_tree_eq
- , testProperty "deepTreeEq" prop_deep_tree_eq
+ , testProperty "shapeEq" prop_shape_eq
+ , testProperty "expandedShapeEq" prop_expanded_shape_eq
, testProperty "expand is identity" prop_expand_id
, testProperty "filter True is identity" prop_filter_id
, testProperty "filter False is empty" prop_filter_empty
, testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative
- , testProperty "restrict is a subtree of both" prop_restrict_subtree ]
+ , testProperty "restrict is a subtree of both" prop_restrict_subtree
+ , testProperty "overlay keeps shape" prop_overlay_shape
+ , testProperty "overlay is superset of over" prop_overlay_super ]
where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x)
name = Name . BS.pack
check_modify =
@@ -261,8 +263,8 @@ tree = [ testCase "modifyTree" check_mod
(working', pristine') <- diffTrees working pristine
let foo_work = findFile working' (floatPath "foo_dir/foo_a")
foo_pris = findFile pristine' (floatPath "foo_dir/foo_a")
- working' `treeEq` pristine'
- @? show working' ++ " `treeEq` " ++ show pristine'
+ working' `shapeEq` pristine'
+ @? show working' ++ " `shapeEq` " ++ show pristine'
assertBool "foo_dir/foo_a is in working'" $ isJust foo_work
assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris
foo_work_c <- readBlob (fromJust foo_work)
@@ -278,27 +280,34 @@ tree = [ testCase "modifyTree" check_mod
assertBool "t1 is empty" $ null (list t1)
assertBool "t2 is empty" $ null (list t2)
- prop_tree_eq x = no_stubs x ==> x `treeEq` x
+ prop_shape_eq x = no_stubs x ==> x `shapeEq` x
where types = x :: Tree Identity
- prop_deep_tree_eq x = runIdentity $ deepTreeEq x x
+ prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x
where types = x :: Tree Identity
- prop_expand_id x = no_stubs x ==> runIdentity (expand x) `treeEq` x
+ prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x
where types = x :: Tree Identity
- prop_filter_id x = runIdentity $ deepTreeEq x $ filter (\_ _ -> True) x
+ prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x
where types = x :: Tree Identity
- prop_filter_empty x = runIdentity $ deepTreeEq emptyTree $ filter (\_ _ -> False) x
+ prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x
where types = x :: Tree Identity
prop_restrict_shape_commutative (t1, t2) =
- no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `treeEq` emptyTree) ==>
- restrict t1 t2 `treeEq` restrict t2 t1
+ no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==>
+ restrict t1 t2 `shapeEq` restrict t2 t1
where types = (t1 :: Tree Identity, t2 :: Tree Identity)
prop_restrict_subtree (t1, t2) =
- no_stubs t1 && not (restrict t1 t2 `treeEq` emptyTree) ==>
+ no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==>
let restricted = S.fromList (map fst $ list $ restrict t1 t2)
orig1 = S.fromList (map fst $ list t1)
orig2 = S.fromList (map fst $ list t2)
in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2]
where types = (t1 :: Tree Identity, t2 :: Tree Identity)
+ prop_overlay_shape (t1 :: Tree Identity, t2) =
+ (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==>
+ runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1
+ prop_overlay_super (t1 :: Tree Identity, t2) =
+ (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==>
+ Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2)
+
packed = [ testCase "loose pristine tree" check_loose
, testCase "load" check_load
@@ -514,18 +523,38 @@ instance Show (Int -> Int) where
-- Test utilities
--
-treeItemEq (File _) (File _) = True
-treeItemEq (SubTree s) (SubTree p) = s `treeEq` p
-treeItemEq _ _ = False
-
-treeEq t r = and $ zipTrees cmp t r
- where cmp _ (Just a) (Just b) = a `treeItemEq` b
- cmp _ _ _ = False
-
-deepTreeEq :: (Monad m) => Tree m -> Tree m -> m Bool
-deepTreeEq a b = do x <- expand a
- y <- expand b
- return $ x `treeEq` y
+shapeEq a b = Just EQ == cmpShape a b
+expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b
+
+cmpcat (x:y:rest) | x == y = cmpcat (x:rest)
+ | x == Just EQ = cmpcat (y:rest)
+ | y == Just EQ = cmpcat (x:rest)
+ | otherwise = Nothing
+cmpcat [x] = x
+cmpcat [] = Just EQ -- empty things are equal
+
+cmpTree a b = do a' <- expand a
+ b' <- expand b
+ con <- contentsEq a' b'
+ return $ cmpcat [cmpShape a' b', con]
+ where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b)
+ cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a
+ b' <- readBlob b
+ return $ Just (compare a' b')
+ cmp _ _ _ = return (Just EQ) -- neutral
+
+cmpShape t r = cmpcat $ zipTrees cmp t r
+ where cmp _ (Just a) (Just b) = a `item` b
+ cmp _ Nothing (Just _) = Just LT
+ cmp _ (Just _) Nothing = Just GT
+ item (File _) (File _) = Just EQ
+ item (SubTree s) (SubTree p) = s `cmpShape` p
+ item _ _ = Nothing
+
+cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering)
+cmpExpandedShape a b = do x <- expand a
+ y <- expand b
+ return $ x `cmpShape` y
nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False
| otherwise = True
diff -rN -u -p old-hashed-storage/Storage/Hashed/Tree.hs new-hashed-storage/Storage/Hashed/Tree.hs
--- old-hashed-storage/Storage/Hashed/Tree.hs 2009-10-25 15:41:04.000000000 +0100
+++ new-hashed-storage/Storage/Hashed/Tree.hs 2009-10-25 15:41:04.000000000 +0100
@@ -25,7 +25,7 @@ module Storage.Hashed.Tree
, FilterTree(..), filter, restrict
-- * Manipulating trees.
- , modifyTree, updateTree, updateSubtrees ) where
+ , modifyTree, updateTree, updateSubtrees, overlay ) where
import Prelude hiding( lookup, filter, all )
import Storage.Hashed.AnchoredPath
@@ -379,3 +379,25 @@ updateTree fun t = do
return t
where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree
update (k, item) = (\new -> (k, new)) <$> fun item
+
+-- | Lay one tree over another. The resulting Tree will look like the base (1st
+-- parameter) Tree, although any items also present in the overlay Tree will be
+-- taken from the overlay. It is not allowed to overlay a different kind of an
+-- object, nor it is allowed for the overlay to add new objects to base. This
+-- means that the overlay Tree should be a subset of the base Tree (although
+-- any extraneous items will be ignored by the implementation).
+overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m
+overlay base over = Tree { items = M.fromList immediate
+ , listImmediate = immediate
+ , treeHash = NoHash }
+ where immediate = [ (n, get n) | (n, _) <- listImmediate base ]
+ get n = case (M.lookup n $ items base, M.lookup n $ items over) of
+ (Just (File _), Just f@(File _)) -> f
+ (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o
+ (Just (Stub b _), Just (SubTree o)) -> Stub (flip overlay o `fmap` b) NoHash
+ (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash
+ (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o
+ b' <- b
+ return $ overlay b' o') NoHash
+ (Just x, _) -> x
+ (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "."
## END of hashed-storage diff
----------
files: bump-the-hashed_storage-dependency-to-__-0_4_1_.dpatch, unnamed
messages: 9066
status: needs-review
title: Bump the hashed-storage dependency to >=... (and 1 more)
__________________________________
Darcs bug tracker <bugs at darcs.net>
<http://bugs.darcs.net/patch16>
__________________________________
-------------- next part --------------
A non-text attachment was scrubbed...
Name: bump-the-hashed_storage-dependency-to-__-0_4_1_.dpatch
Type: text/x-darcs-patch
Size: 56497 bytes
Desc: not available
URL: <http://lists.osuosl.org/pipermail/darcs-users/attachments/20091027/238526a8/attachment-0001.bin>
-------------- next part --------------
An embedded and charset-unspecified text was scrubbed...
Name: unnamed
URL: <http://lists.osuosl.org/pipermail/darcs-users/attachments/20091027/238526a8/attachment-0001.diff>
More information about the darcs-users
mailing list