diff options
Diffstat (limited to 'Git')
| -rw-r--r-- | Git/Tree.hs | 99 |
1 files changed, 71 insertions, 28 deletions
diff --git a/Git/Tree.hs b/Git/Tree.hs index 3560c095e..ea48a1f12 100644 --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} module Git.Tree ( Tree(..), @@ -29,6 +29,7 @@ import Numeric import System.Posix.Types import Control.Monad.IO.Class import qualified Data.Set as S +import qualified Data.Map as M newtype Tree = Tree [TreeContent] deriving (Show) @@ -39,7 +40,7 @@ data TreeContent | RecordedSubTree TopFilePath Sha [TreeContent] -- A subtree that has not yet been recorded in git. | NewSubTree TopFilePath [TreeContent] - deriving (Show, Eq) + deriving (Show, Eq, Ord) {- Gets the Tree for a Ref. -} getTree :: Ref -> Repo -> IO Tree @@ -112,11 +113,35 @@ data TreeItem = TreeItem TopFilePath FileMode Sha treeItemToTreeContent :: TreeItem -> TreeContent treeItemToTreeContent (TreeItem f m s) = TreeBlob f m s - --- FIXME: When addtreeitems has an item in a new --- subdirectory, no subtree contains it. We need to add a --- new subtree in this case, but not in the case where the --- subdirectory already exists in the tree. + +treeItemsToTree :: [TreeItem] -> Tree +treeItemsToTree = go M.empty + where + go m [] = Tree $ filter (notElem '/' . gitPath) (M.elems m) + go m (i:is) + | '/' `notElem` p = + go (M.insert p (treeItemToTreeContent i) m) is + | otherwise = case M.lookup idir m of + Just (NewSubTree d l) -> + go (addsubtree idir m (NewSubTree d (c:l))) is + _ -> + go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is + where + p = gitPath i + idir = takeDirectory p + c = treeItemToTreeContent i + + addsubtree d m t + | elem '/' d = + let m' = M.insert d t m + in case M.lookup parent m' of + Just (NewSubTree d' l) -> + let l' = filter (\ti -> gitPath ti /= d) l + in addsubtree parent m' (NewSubTree d' (t:l')) + _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) + | otherwise = M.insert d t m + where + parent = takeDirectory d {- Applies an adjustment to items in a tree. - @@ -139,7 +164,7 @@ adjustTree adjusttreeitem addtreeitems removefiles r repo = withMkTreeHandle repo $ \h -> do (l, cleanup) <- liftIO $ lsTreeWithObjects r repo (l', _, _) <- go h False [] inTopTree l - l'' <- adjustlist topitem l' + l'' <- adjustlist h inTopTree (const True) l' sha <- liftIO $ mkTree h l'' void $ liftIO cleanup return sha @@ -158,7 +183,7 @@ adjustTree adjusttreeitem addtreeitems removefiles r repo = in go h modified (blob:c) intree is Just TreeObject -> do (sl, modified, is') <- go h False [] (beneathSubTree i) is - sl' <- adjustlist (inTree i) sl + sl' <- adjustlist h (inTree i) (beneathSubTree i) sl subtree <- if modified || sl' /= sl then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl' else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) [] @@ -166,12 +191,17 @@ adjustTree adjusttreeitem addtreeitems removefiles r repo = go h modified' (subtree : c) intree is' _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") | otherwise = return (c, wasmodified, i:is) - adjustlist ishere l = do - let added = filter ishere addtreeitems - let l' = map treeItemToTreeContent added ++ l - let l'' = filter (not . removed) l' - return l'' - topitem (TreeItem f _ _) = inTopTree' f + + adjustlist h ishere underhere l = do + let (addhere, rest) = partition ishere addtreeitems + let l' = filter (not . removed) $ + map treeItemToTreeContent addhere ++ l + let inl i = any (\t -> beneathSubTree t i) l' + let (Tree addunderhere) = treeItemsToTree $ + filter (\i -> underhere i && not (inl i)) rest + addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere + return (addunderhere'++l') + removeset = S.fromList removefiles removed (TreeBlob f _ _) = S.member f removeset removed _ = False @@ -199,21 +229,34 @@ extractTree l = case go [] inTopTree l of | otherwise = Right (t, i:is) parseerr = Left -type InTree = LsTree.TreeItem -> Bool +class GitPath t where + gitPath :: t -> FilePath + +instance GitPath FilePath where + gitPath = id + +instance GitPath TopFilePath where + gitPath = getTopFilePath -inTopTree :: InTree -inTopTree = inTopTree' . LsTree.file +instance GitPath TreeItem where + gitPath (TreeItem f _ _) = gitPath f -inTopTree' :: TopFilePath -> Bool -inTopTree' f = takeDirectory (getTopFilePath f) == "." +instance GitPath LsTree.TreeItem where + gitPath = gitPath . LsTree.file -beneathSubTree :: LsTree.TreeItem -> InTree -beneathSubTree t = - let prefix = getTopFilePath (LsTree.file t) ++ "/" - in (\i -> prefix `isPrefixOf` getTopFilePath (LsTree.file i)) +instance GitPath TreeContent where + gitPath (TreeBlob f _ _) = gitPath f + gitPath (RecordedSubTree f _ _) = gitPath f + gitPath (NewSubTree f _) = gitPath f -inTree :: LsTree.TreeItem -> TreeItem -> Bool -inTree = inTree' . LsTree.file +inTopTree :: GitPath t => t -> Bool +inTopTree = inTree "." -inTree' :: TopFilePath -> TreeItem -> Bool -inTree' f (TreeItem f' _ _) = takeDirectory (getTopFilePath f') == takeDirectory (getTopFilePath f) +inTree :: (GitPath t, GitPath f) => t -> f -> Bool +inTree t f = gitPath t == takeDirectory (gitPath f) + +beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool +beneathSubTree t f = prefix `isPrefixOf` gitPath f + where + tp = gitPath t + prefix = if null tp then tp else tp ++ "/" |