refactor and function name cleanup

(oops, I had a calcMerge and a calc_merge!)
This commit is contained in:
Joey Hess 2012-06-08 00:29:39 -04:00
parent 7d78cbf97c
commit d45a9a7831
5 changed files with 58 additions and 46 deletions

View file

@ -261,15 +261,15 @@ files = withIndexUpdate $ do
- in changes from other branches.
-}
genIndex :: Git.Repo -> IO ()
genIndex g = Git.UpdateIndex.stream_update_index g
[Git.UpdateIndex.ls_tree fullname g]
genIndex g = Git.UpdateIndex.streamUpdateIndex g
[Git.UpdateIndex.lsTree fullname g]
{- Merges the specified refs into the index.
- Any changes staged in the index will be preserved. -}
mergeIndex :: [Git.Ref] -> Annex ()
mergeIndex branches = do
h <- catFileHandle
inRepo $ \g -> Git.UnionMerge.merge_index h g branches
inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches
{- Runs an action using the branch's index file. -}
withIndex :: Annex a -> Annex a
@ -338,13 +338,13 @@ stageJournal = do
g <- gitRepo
withIndex $ liftIO $ do
h <- hashObjectStart g
Git.UpdateIndex.stream_update_index g
Git.UpdateIndex.streamUpdateIndex g
[genstream (gitAnnexJournalDir g) h fs]
hashObjectStop h
where
genstream dir h fs streamer = forM_ fs $ \file -> do
let path = dir </> file
sha <- hashFile h path
_ <- streamer $ Git.UpdateIndex.update_index_line
_ <- streamer $ Git.UpdateIndex.updateIndexLine
sha FileBlob (asTopFilePath $ fileJournal file)
removeFile path

View file

@ -19,9 +19,6 @@ import qualified Annex.Queue
import qualified Command.Add
import qualified Git.Command
import qualified Git.UpdateIndex
import Git.HashObject
import Git.Types
import Git.FilePath
import qualified Backend
import Annex.Content
@ -140,9 +137,6 @@ onErr = warning
{- Adds a symlink to the index, without ever accessing the actual symlink
- on disk. -}
stageSymlink :: FilePath -> String -> Annex ()
stageSymlink file linktext = do
line <- Git.UpdateIndex.update_index_line
<$> inRepo (hashObject BlobObject linktext)
<*> pure SymlinkBlob
<*> inRepo (toTopFilePath file)
Annex.Queue.addUpdateIndex $ \streamer -> streamer line
stageSymlink file linktext =
Annex.Queue.addUpdateIndex =<<
inRepo (Git.UpdateIndex.stageSymlink file linktext)

View file

@ -151,7 +151,7 @@ flush (Queue _ lim m) repo = do
- this allows queueing commands that do not need a list of files. -}
runAction :: Repo -> Action -> IO ()
runAction repo (UpdateIndexAction streamers) =
Git.UpdateIndex.stream_update_index repo streamers
Git.UpdateIndex.streamUpdateIndex repo streamers
runAction repo action@(CommandAction {}) =
pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs
where

View file

@ -7,7 +7,7 @@
module Git.UnionMerge (
merge,
merge_index
mergeIndex
) where
import qualified Data.Text.Lazy as L
@ -32,40 +32,40 @@ import Git.FilePath
merge :: Ref -> Ref -> Repo -> IO ()
merge x y repo = do
h <- catFileStart repo
stream_update_index repo
[ ls_tree x repo
, merge_trees x y h repo
streamUpdateIndex repo
[ lsTree x repo
, mergeTrees x y h repo
]
catFileStop h
{- Merges a list of branches into the index. Previously staged changed in
{- Merges a list of branches into the index. Previously staged changes in
- the index are preserved (and participate in the merge). -}
merge_index :: CatFileHandle -> Repo -> [Ref] -> IO ()
merge_index h repo bs =
stream_update_index repo $ map (\b -> merge_tree_index b h repo) bs
mergeIndex :: CatFileHandle -> Repo -> [Ref] -> IO ()
mergeIndex h repo bs =
streamUpdateIndex repo $ map (\b -> mergeTreeIndex b h repo) bs
{- For merging two trees. -}
merge_trees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer
merge_trees (Ref x) (Ref y) h = calc_merge h $ "diff-tree":diff_opts ++ [x, y]
mergeTrees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer
mergeTrees (Ref x) (Ref y) h = doMerge h $ "diff-tree":diffOpts ++ [x, y]
{- For merging a single tree into the index. -}
merge_tree_index :: Ref -> CatFileHandle -> Repo -> Streamer
merge_tree_index (Ref x) h = calc_merge h $
"diff-index" : diff_opts ++ ["--cached", x]
mergeTreeIndex :: Ref -> CatFileHandle -> Repo -> Streamer
mergeTreeIndex (Ref x) h = doMerge h $
"diff-index" : diffOpts ++ ["--cached", x]
diff_opts :: [String]
diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
diffOpts :: [String]
diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"]
{- Calculates how to perform a merge, using git to get a raw diff,
- and generating update-index input. -}
calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer
calc_merge ch differ repo streamer = gendiff >>= go
{- Streams update-index changes to perform a merge,
- using git to get a raw diff. -}
doMerge :: CatFileHandle -> [String] -> Repo -> Streamer
doMerge ch differ repo streamer = gendiff >>= go
where
gendiff = pipeNullSplit (map Param differ) repo
go [] = noop
go (info:file:rest) = mergeFile info file ch repo >>=
maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = error "calc_merge parse error"
go (_:[]) = error $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the
@ -81,7 +81,8 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of
[_colonmode, _bmode, asha, bsha, _status] = words info
getcontents s = map L.unpack . L.lines .
L.decodeUtf8 <$> catObject h s
use sha = return $ Just $ update_index_line sha FileBlob $ asTopFilePath file
use sha = return $ Just $
updateIndexLine sha FileBlob $ asTopFilePath file
{- Calculates a union merge between a list of refs, with contents.
-

View file

@ -7,9 +7,11 @@
module Git.UpdateIndex (
Streamer,
stream_update_index,
ls_tree,
update_index_line,
pureStreamer,
streamUpdateIndex,
lsTree,
updateIndexLine,
stageSymlink
) where
import System.Cmd.Utils
@ -19,14 +21,19 @@ import Git
import Git.Types
import Git.Command
import Git.FilePath
import Git.HashObject
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
type Streamer = (String -> IO ()) -> IO ()
{- A streamer with a precalculated value. -}
pureStreamer :: String -> Streamer
pureStreamer s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
stream_update_index :: Repo -> [Streamer] -> IO ()
stream_update_index repo as = do
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = do
(p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo)
fileEncoding h
forM_ as (stream h)
@ -39,14 +46,24 @@ stream_update_index repo as = do
hPutStr h s
hPutStr h "\0"
{- Gets the current tree for a ref. -}
ls_tree :: Ref -> Repo -> Streamer
ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
lsTree :: Ref -> Repo -> Streamer
lsTree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
{- Generates a line suitable to be fed into update-index, to add
- a given file with a given sha. -}
update_index_line :: Sha -> BlobType -> TopFilePath -> String
update_index_line sha filetype file =
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
updateIndexLine sha filetype file =
show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file
{- A streamer that adds a symlink to the index. -}
stageSymlink :: FilePath -> String -> Repo -> IO Streamer
stageSymlink file linktext repo = do
line <- updateIndexLine
<$> hashObject BlobObject linktext repo
<*> pure SymlinkBlob
<*> toTopFilePath file repo
return $ pureStreamer line