mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

refactor

Browse source
This commit is contained in:
Joey Hess 2016-02-23 21:56:03 -04:00
parent e08bebf0eb
commit 85b05a29df
Failed to extract signature
1 changed files with 26 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
Git/Tree.hs
View file

@ -118,53 +118,65 @@ adjustTree :: MonadIO m => (TreeItem -> m (Maybe TreeItem)) -> Ref -> Repo -> m
adjustTree adjust r repo = do adjustTree adjust r repo = do
(l, cleanup) <- liftIO $ lsTreeWithObjects r repo (l, cleanup) <- liftIO $ lsTreeWithObjects r repo
h <- liftIO $ startRecordTree repo h <- liftIO $ startRecordTree repo
(l', _, _) <- go h False [] "" l (l', _, _) <- go h False [] topTree l
sha <- liftIO $ recordTree (Tree l') repo liftIO $ print l'
sha <- liftIO $ mkTree h l'
liftIO $ CoProcess.stop h
void $ liftIO cleanup void $ liftIO cleanup
return sha return sha
where where
go _ wasmodified c _ [] = return (c, wasmodified, []) go _ wasmodified c _ [] = return (c, wasmodified, [])
go h wasmodified c prefix (i:is) go h wasmodified c intree (i:is)
| prefix `isPrefixOf` getTopFilePath (LsTree.file i) = | intree i =
case readObjectType (LsTree.typeobj i) of case readObjectType (LsTree.typeobj i) of
Just BlobObject -> do Just BlobObject -> do
let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i) let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
v <- adjust ti v <- adjust ti
case v of case v of
Nothing -> go h True c prefix is Nothing -> go h True c intree is
Just ti'@(TreeItem f m s) -> Just ti'@(TreeItem f m s) ->
let modified = ti' /= ti let modified = ti' /= ti
blob = TreeBlob f m s blob = TreeBlob f m s
in go h (wasmodified || modified) (blob:c) prefix is in go h (wasmodified || modified) (blob:c) intree is
Just TreeObject -> do Just TreeObject -> do
(sl, modified, is') <- go h False [] (getTopFilePath (LsTree.file i) ++ "/") is (sl, modified, is') <- go h False [] (subTree i) is
subtree <- if modified subtree <- if modified
then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl
else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) [] else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) []
go h (modified || wasmodified) (subtree : c) prefix is' go h (modified || wasmodified) (subtree : c) intree is'
_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") _ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
| otherwise = return (c, wasmodified, i:is) | otherwise = return (c, wasmodified, i:is)
{- Assumes the list is ordered, with tree objects coming right before their {- Assumes the list is ordered, with tree objects coming right before their
- contents. -} - contents. -}
extractTree :: [LsTree.TreeItem] -> Either String Tree extractTree :: [LsTree.TreeItem] -> Either String Tree
extractTree l = case go [] "" l of extractTree l = case go [] topTree l of
Right (t, []) -> Right (Tree t) Right (t, []) -> Right (Tree t)
Right _ -> parseerr "unexpected tree form" Right _ -> parseerr "unexpected tree form"
Left e -> parseerr e Left e -> parseerr e
where where
go t _ [] = Right (t, []) go t _ [] = Right (t, [])
go t prefix (i:is) go t intree (i:is)
| prefix `isPrefixOf` getTopFilePath (LsTree.file i) = | intree i =
case readObjectType (LsTree.typeobj i) of case readObjectType (LsTree.typeobj i) of
Just BlobObject -> Just BlobObject ->
let b = TreeBlob (LsTree.file i) (LsTree.mode i) (LsTree.sha i) let b = TreeBlob (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
in go (b:t) prefix is in go (b:t) intree is
Just TreeObject -> case go [] (getTopFilePath (LsTree.file i) ++ "/") is of Just TreeObject -> case go [] (subTree i) is of
Right (subtree, is') -> Right (subtree, is') ->
let st = RecordedSubTree (LsTree.file i) (LsTree.sha i) subtree let st = RecordedSubTree (LsTree.file i) (LsTree.sha i) subtree
in go (st:t) prefix is' in go (st:t) intree is'
Left e -> Left e Left e -> Left e
_ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") _ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
| otherwise = Right (t, i:is) | otherwise = Right (t, i:is)
parseerr = Left parseerr = Left
type InTree = LsTree.TreeItem -> Bool
topTree :: InTree
topTree = notElem '/' . getTopFilePath . LsTree.file
subTree :: LsTree.TreeItem -> InTree
subTree i =
let prefix = getTopFilePath (LsTree.file i) ++ "/"
in (\i -> prefix `isPrefixOf` getTopFilePath (LsTree.file i))