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 49923a7353f8259b0670d6345f9dad429b922f37..06f8c2108107334113c208a1310dc16904442e52 100644 (file)
--- 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)