diff options
| -rw-r--r-- | Annex/AdjustedBranch.hs | 12 | ||||
| -rw-r--r-- | Git/Tree.hs | 49 |
2 files changed, 43 insertions, 18 deletions
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index ce565a754..030bdb99e 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -142,7 +142,7 @@ adjustTree :: Adjustment -> Direction -> Ref -> Annex Sha adjustTree adj direction orig = do h <- inRepo hashObjectStart let toadj = adjustTreeItem adj direction h - treesha <- Git.Tree.adjustTree toadj [] orig =<< Annex.gitRepo + treesha <- Git.Tree.adjustTree toadj [] [] orig =<< Annex.gitRepo liftIO $ hashObjectStop h return treesha @@ -293,11 +293,15 @@ reverseAdjustedCommit h newparent adj (csha, c) origbranch Left $ "unable to propigate merge commit " ++ show csha ++ " back to " ++ show origbranch | otherwise = do (diff, cleanup) <- inRepo (Git.DiffTree.commitDiff csha) - let (adds, changes) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff + let (adds, others) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff + let (removes, changes) = partition (\dti -> Git.DiffTree.dstsha dti == nullSha) others adds' <- catMaybes <$> mapM (adjustTreeItem adj Reverse h) (map diffTreeToTreeItem adds) - treesha <- Git.Tree.adjustTree (propchanges changes) - adds' newparent + treesha <- Git.Tree.adjustTree + (propchanges changes) + adds' + (map Git.DiffTree.file removes) + newparent =<< Annex.gitRepo void $ liftIO cleanup revadjcommit <- inRepo $ commitWithMetaData diff --git a/Git/Tree.hs b/Git/Tree.hs index 7f28bcb6c..91d81844b 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -28,6 +28,7 @@ import qualified Utility.CoProcess as CoProcess import Numeric import System.Posix.Types import Control.Monad.IO.Class +import qualified Data.Set as S newtype Tree = Tree [TreeContent] deriving (Show) @@ -38,7 +39,7 @@ data TreeContent | RecordedSubTree TopFilePath Sha [TreeContent] -- A subtree that has not yet been recorded in git. | NewSubTree TopFilePath [TreeContent] - deriving (Show) + deriving (Show, Eq) {- Gets the Tree for a Ref. -} getTree :: Ref -> Repo -> IO Tree @@ -113,18 +114,31 @@ treeItemToTreeContent :: TreeItem -> TreeContent treeItemToTreeContent (TreeItem f m s) = TreeBlob f m s {- Applies an adjustment to items in a tree. - - Can also add new items to the tree. - - While less flexible than using getTree and recordTree, this avoids - buffering the whole tree in memory. -} -adjustTree :: (MonadIO m, MonadMask m) => (TreeItem -> m (Maybe TreeItem)) -> [TreeItem] -> Ref -> Repo -> m Sha -adjustTree adjusttreeitem addtreeitems r repo = withMkTreeHandle repo $ \h -> do - (l, cleanup) <- liftIO $ lsTreeWithObjects r repo - (l', _, _) <- go h False [] inTopTree l - sha <- liftIO $ mkTree h (map treeItemToTreeContent addedtotop ++ l') - void $ liftIO cleanup - return sha +adjustTree + :: (MonadIO m, MonadMask m) + => (TreeItem -> m (Maybe TreeItem)) + -- ^ Adjust an item in the tree. Nothing deletes the item. + -- Cannot move the item to a different tree. + -> [TreeItem] + -- ^ New items to add to the tree. + -> [TopFilePath] + -- ^ Files to remove from the tree. + -> Ref + -> Repo + -> m Sha +adjustTree adjusttreeitem addtreeitems removefiles r repo = + withMkTreeHandle repo $ \h -> do + (l, cleanup) <- liftIO $ lsTreeWithObjects r repo + (l', _, _) <- go h False [] inTopTree l + sha <- liftIO $ mkTree h $ + filter (not . removed) $ + map treeItemToTreeContent (filter topitem addtreeitems) ++ l' + void $ liftIO cleanup + return sha where go _ wasmodified c _ [] = return (c, wasmodified, []) go h wasmodified c intree (i:is) @@ -141,15 +155,19 @@ adjustTree adjusttreeitem addtreeitems r repo = withMkTreeHandle repo $ \h -> do Just TreeObject -> do (sl, modified, is') <- go h False [] (beneathSubTree i) is let added = filter (inTree i) addtreeitems - subtree <- if modified || not (null added) - then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) - (map treeItemToTreeContent added ++ sl) + let sl' = map treeItemToTreeContent added ++ sl + let sl'' = filter (not . removed) sl' + subtree <- if modified || sl'' /= sl + then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl'' else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) [] let !modified' = modified || wasmodified go h modified' (subtree : c) intree is' _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") | otherwise = return (c, wasmodified, i:is) - addedtotop = filter (\(TreeItem f _ _) -> inTopTree' f) addtreeitems + topitem (TreeItem f _ _) = inTopTree' f + removeset = S.fromList removefiles + removed (TreeBlob f _ _) = S.member f removeset + removed _ = False {- Assumes the list is ordered, with tree objects coming right before their - contents. -} @@ -188,4 +206,7 @@ beneathSubTree t = in (\i -> prefix `isPrefixOf` getTopFilePath (LsTree.file i)) inTree :: LsTree.TreeItem -> TreeItem -> Bool -inTree t (TreeItem f _ _) = takeDirectory (getTopFilePath f) == takeDirectory (getTopFilePath (LsTree.file t)) +inTree = inTree' . LsTree.file + +inTree' :: TopFilePath -> TreeItem -> Bool +inTree' f (TreeItem f' _ _) = takeDirectory (getTopFilePath f') == takeDirectory (getTopFilePath f) |