[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@mornfall.net>
  * Bump the hashed-storage dependency to >= 0.4.1.

Sun Oct 25 15:35:36 CET 2009  Petr Rockai <me@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@mornfall.net>
  * More sophisticated QC for overlay.
Sun Oct 25 15:11:41 CET 2009  Petr Rockai <me@mornfall.net>
  * Improve the shape comparison operators in Test.
Sun Oct 25 14:53:30 CET 2009  Petr Rockai <me@mornfall.net>
  * Document and somewhat re-formulate overlay (in Tree).
Sun Oct 25 14:50:25 CET 2009  Petr Rockai <me@mornfall.net>
  * Implement basic QC for Tree overlay.
Tue Oct 20 17:12:37 CEST 2009  Petr Rockai <me@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

Attachments

• bump-the-hashed_storage-dependency-to-__-0_4_1_.dpatch
• unnamed

Hi Jason, how do you feel about reviewing this patch (and having a look at the
associated hashed-storage patch)?  

I think I'm trying to spread this throughout the team so that we all get some
experience looking at this sort of code.  Dunno if it's sensible or just
inefficient.

On Sat, Oct 31, 2009 at 12:04 PM, Eric Kow <bugs@darcs.net> wrote:

>
> Eric Kow <kowey@darcs.net> added the comment:
>
> Hi Jason, how do you feel about reviewing this patch (and having a look at
> the
> associated hashed-storage patch)?
>

I'd love to look at it carefully, and it's been on my list, but I won't have
time this weekend.  I may not have time during the week either.  It's hard
for me to commit to a time right now.

Sorry,
Jason

Attachments

• unnamed

Thanks for the rapid response, Jason.  Look at us patch-track!  
Reinier: can I instead ask you to review this one and patch31?