refactor and function name cleanup
(oops, I had a calcMerge and a calc_merge!)
This commit is contained in:
parent
7d78cbf97c
commit
d45a9a7831
5 changed files with 58 additions and 46 deletions
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue