better encapsulation
This commit is contained in:
parent
4ea36b8c63
commit
e5dd91b189
1 changed files with 16 additions and 18 deletions
34
Git/Tree.hs
34
Git/Tree.hs
|
@ -52,6 +52,15 @@ getTree r repo = do
|
||||||
lsTreeWithObjects :: Ref -> Repo -> IO ([LsTree.TreeItem], IO Bool)
|
lsTreeWithObjects :: Ref -> Repo -> IO ([LsTree.TreeItem], IO Bool)
|
||||||
lsTreeWithObjects = LsTree.lsTree' [Param "-t"]
|
lsTreeWithObjects = LsTree.lsTree' [Param "-t"]
|
||||||
|
|
||||||
|
newtype MkTreeHandle = MkTreeHandle CoProcess.CoProcessHandle
|
||||||
|
|
||||||
|
withMkTreeHandle :: (MonadIO m, MonadMask m) => Repo -> (MkTreeHandle -> m a) -> m a
|
||||||
|
withMkTreeHandle repo a = bracketIO setup cleanup (a . MkTreeHandle)
|
||||||
|
where
|
||||||
|
setup = CoProcess.rawMode =<< gitCoProcessStart False ps repo
|
||||||
|
ps = [Param "mktree", Param "--batch", Param "-z"]
|
||||||
|
cleanup = CoProcess.stop
|
||||||
|
|
||||||
{- Records a Tree in the Repo, returning its Sha.
|
{- Records a Tree in the Repo, returning its Sha.
|
||||||
-
|
-
|
||||||
- Efficiently handles subtrees, by only recording ones that have not
|
- Efficiently handles subtrees, by only recording ones that have not
|
||||||
|
@ -60,31 +69,22 @@ lsTreeWithObjects = LsTree.lsTree' [Param "-t"]
|
||||||
- interface.
|
- interface.
|
||||||
-}
|
-}
|
||||||
recordTree :: Tree -> Repo -> IO Sha
|
recordTree :: Tree -> Repo -> IO Sha
|
||||||
recordTree t repo = do
|
recordTree t repo = withMkTreeHandle repo $ \h -> recordTree' h t
|
||||||
h <- startRecordTree repo
|
|
||||||
sha <- recordTree' h t
|
|
||||||
CoProcess.stop h
|
|
||||||
return sha
|
|
||||||
|
|
||||||
startRecordTree :: Repo -> IO CoProcess.CoProcessHandle
|
recordTree' :: MkTreeHandle -> Tree -> IO Sha
|
||||||
startRecordTree repo = CoProcess.rawMode =<< gitCoProcessStart False ps repo
|
|
||||||
where
|
|
||||||
ps = [Param "mktree", Param "--batch", Param "-z"]
|
|
||||||
|
|
||||||
recordTree' :: CoProcess.CoProcessHandle -> Tree -> IO Sha
|
|
||||||
recordTree' h (Tree l) = mkTree h =<< mapM (recordSubTree h) l
|
recordTree' h (Tree l) = mkTree h =<< mapM (recordSubTree h) l
|
||||||
|
|
||||||
{- Note that the returned RecordedSubTree does not have its [TreeContent]
|
{- Note that the returned RecordedSubTree does not have its [TreeContent]
|
||||||
- list populated. This is a memory optimisation, since the list is not
|
- list populated. This is a memory optimisation, since the list is not
|
||||||
- used. -}
|
- used. -}
|
||||||
recordSubTree :: CoProcess.CoProcessHandle -> TreeContent -> IO TreeContent
|
recordSubTree :: MkTreeHandle -> TreeContent -> IO TreeContent
|
||||||
recordSubTree h (NewSubTree d l) = do
|
recordSubTree h (NewSubTree d l) = do
|
||||||
sha <- mkTree h =<< mapM (recordSubTree h) l
|
sha <- mkTree h =<< mapM (recordSubTree h) l
|
||||||
return (RecordedSubTree d sha [])
|
return (RecordedSubTree d sha [])
|
||||||
recordSubTree _ alreadyrecorded = return alreadyrecorded
|
recordSubTree _ alreadyrecorded = return alreadyrecorded
|
||||||
|
|
||||||
mkTree :: CoProcess.CoProcessHandle -> [TreeContent] -> IO Sha
|
mkTree :: MkTreeHandle -> [TreeContent] -> IO Sha
|
||||||
mkTree cp l = CoProcess.query cp send receive
|
mkTree (MkTreeHandle cp) l = CoProcess.query cp send receive
|
||||||
where
|
where
|
||||||
send h = do
|
send h = do
|
||||||
forM_ l $ \i -> hPutStr h $ case i of
|
forM_ l $ \i -> hPutStr h $ case i of
|
||||||
|
@ -114,13 +114,11 @@ data TreeItem = TreeItem TopFilePath FileMode Sha
|
||||||
- While less flexible than using getTree and recordTree, this avoids
|
- While less flexible than using getTree and recordTree, this avoids
|
||||||
- buffering the whole tree in memory.
|
- buffering the whole tree in memory.
|
||||||
-}
|
-}
|
||||||
adjustTree :: MonadIO m => (TreeItem -> m (Maybe TreeItem)) -> Ref -> Repo -> m Sha
|
adjustTree :: (MonadIO m, MonadMask m) => (TreeItem -> m (Maybe TreeItem)) -> Ref -> Repo -> m Sha
|
||||||
adjustTree adjust r repo = do
|
adjustTree adjust r repo = withMkTreeHandle repo $ \h -> do
|
||||||
(l, cleanup) <- liftIO $ lsTreeWithObjects r repo
|
(l, cleanup) <- liftIO $ lsTreeWithObjects r repo
|
||||||
h <- liftIO $ startRecordTree repo
|
|
||||||
(l', _, _) <- go h False [] topTree l
|
(l', _, _) <- go h False [] topTree l
|
||||||
sha <- liftIO $ mkTree h l'
|
sha <- liftIO $ mkTree h l'
|
||||||
liftIO $ CoProcess.stop h
|
|
||||||
void $ liftIO cleanup
|
void $ liftIO cleanup
|
||||||
return sha
|
return sha
|
||||||
where
|
where
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue