From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 10 Jan 2024 20:36:44 +0000 (-0400)
Subject: Revert "optimise adjustTree when adding many TreeItems"
X-Git-Tag: archive/raspbian/10.20250416-2+rpi1~1^2~29^2~53
X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=d9f36085c6941f8f1de008c70ab018bbaca7e696;p=git-annex.git

Revert "optimise adjustTree when adding many TreeItems"

This reverts commit 2c86651180d5c8648b8244be894c26bc98a6c334.

That commit caused a test failure and problably wrong trees to be
imported, so revert until that is fixed.
---

diff --git a/Git/Tree.hs b/Git/Tree.hs
index 49923a7353..06f8c21081 100644
--- a/Git/Tree.hs
+++ b/Git/Tree.hs
@@ -1,12 +1,11 @@
 {- git trees
  -
- - Copyright 2016-2023 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
 {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Git.Tree (
 	Tree(..),
@@ -232,7 +231,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
 	withMkTreeHandle repo $ \h -> do
 		(l, cleanup) <- liftIO $ lsTreeWithObjects LsTree.LsTreeRecursive r repo
 		(l', _, _) <- go h False [] 1 inTopTree l
-		l'' <- adjustlist h 0 inTopTree topTreePath l'
+		l'' <- adjustlist h 0 inTopTree (const True) l'
 		sha <- liftIO $ mkTree h l''
 		void $ liftIO cleanup
 		return sha
@@ -251,7 +250,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
 						in go h modified (blob:c) depth intree is
 			Just TreeObject -> do
 				(sl, modified, is') <- go h False [] (depth+1) (beneathSubTree i) is
-				sl' <- adjustlist h depth (inTree i) (gitPath i) sl
+				sl' <- adjustlist h depth (inTree i) (beneathSubTree i) sl
 				let slmodified = sl' /= sl
 				subtree <- if modified || slmodified
 					then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl'
@@ -269,22 +268,16 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
 			_ -> giveup ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
 		| otherwise = return (c, wasmodified, i:is)
 
-	adjustlist h depth ishere herepath l = do
-		let addhere = fromMaybe [] $ M.lookup herepath addtreeitempathmap
+	adjustlist h depth ishere underhere l = do
+		let (addhere, rest) = partition ishere addtreeitems
 		let l' = filter (not . removed) $
 			addoldnew l (map treeItemToTreeContent addhere)
 		let inl i = any (\t -> beneathSubTree t i) l'
 		let (Tree addunderhere) = flattenTree depth $ treeItemsToTree $
-			filter (not . inl) $ if herepath == topTreePath
-				then filter (not . ishere) addtreeitems
-				else fromMaybe [] $
-					M.lookup (subTreePrefix herepath) addtreeitemprefixmap
+			filter (\i -> underhere i && not (inl i)) rest
 		addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere
 		return (addoldnew l' addunderhere')
 
-	addtreeitempathmap = mkPathMap addtreeitems
-	addtreeitemprefixmap = mkPathPrefixMap addtreeitems
-
 	removeset = S.fromList $ map (P.normalise . gitPath) removefiles
 	removed (TreeBlob f _ _) = S.member (P.normalise (gitPath f)) removeset
 	removed (TreeCommit f _ _) = S.member (P.normalise (gitPath f)) removeset
@@ -362,8 +355,12 @@ graftTree' subtree graftloc basetree repo hdl = go basetree subdirs graftdirs
 
 	subdirs = P.splitDirectories $ gitPath graftloc
 
+	-- For a graftloc of "foo/bar/baz", this generates
+	-- ["foo", "foo/bar", "foo/bar/baz"]
 	graftdirs = map (asTopFilePath . toInternalGitPath) $
-		pathPrefixes subdirs
+		mkpaths [] subdirs
+	mkpaths _ [] = []
+	mkpaths base (d:rest) = (P.joinPath base P.</> d) : mkpaths (base ++ [d]) rest
 
 {- Assumes the list is ordered, with tree objects coming right before their
  - contents. -}
@@ -416,50 +413,13 @@ instance GitPath TreeContent where
 	gitPath (TreeCommit f _ _) = gitPath f
 
 inTopTree :: GitPath t => t -> Bool
-inTopTree = inTree topTreePath
-
-topTreePath :: RawFilePath
-topTreePath = "."
+inTopTree = inTree "."
 
 inTree :: (GitPath t, GitPath f) => t -> f -> Bool
 inTree t f = gitPath t == P.takeDirectory (gitPath f)
 
 beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool
-beneathSubTree t f = subTreePrefix t `B.isPrefixOf` subTreePath f
-
-subTreePath :: GitPath t => t -> RawFilePath
-subTreePath = P.normalise . gitPath
-
-subTreePrefix :: GitPath t => t -> RawFilePath
-subTreePrefix t
-	| B.null tp = tp
-	| otherwise = P.addTrailingPathSeparator (P.normalise tp)
+beneathSubTree t f = prefix `B.isPrefixOf` P.normalise (gitPath f)
   where
 	tp = gitPath t
-
-{- Makes a Map where the keys are directories, and the values
- - are the items located in that directory.
- -
- - Values that are not in any subdirectory are placed in
- - the topTreePath key.
- -}
-mkPathMap :: GitPath t => [t] -> M.Map RawFilePath [t]
-mkPathMap l = M.fromListWith (++) $
-	map (\ti -> (P.takeDirectory (gitPath ti), [ti])) l
-
-{- Input is eg splitDirectories "foo/bar/baz",
- - for which it will output ["foo", "foo/bar", "foo/bar/baz"] -}
-pathPrefixes :: [RawFilePath] -> [RawFilePath]
-pathPrefixes = go []
-  where
-	go _ [] = []
-	go base (d:rest) = (P.joinPath base P.</> d) : go (base ++ [d]) rest
-
-{- Makes a Map where the keys are all path prefixes, 
- - and the values are items with that path prefix.
- -}
-mkPathPrefixMap :: GitPath t => [t] -> M.Map RawFilePath [t]
-mkPathPrefixMap l = M.fromListWith (++) $ concatMap go l
-  where
-	go ti = map (\p -> (p, [ti]))
-		(pathPrefixes $ P.splitDirectories $ subTreePath ti)
+	prefix = if B.null tp then tp else P.addTrailingPathSeparator (P.normalise tp)