improved direct mode dir/file conflicted merge resultion, using tree grafting

2 files changed, 20 insertions, 22 deletions

diff --git a/Command/Sync.hs b/Command/Sync.hs
index 22a6b6f4d..838e40f48 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -21,6 +21,7 @@ import Annex.Link
 import Annex.Hook
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
+import qualified Git.UpdateIndex as UpdateIndex
 import qualified Git.Merge
 import qualified Git.Branch
 import qualified Git.Ref
@@ -314,11 +315,11 @@ mergeFrom branch = do
 		, go
 		)
   where
-	go = inRepo (Git.Merge.mergeNonInteractive branch) <||> resolveMerge
+	go = inRepo (Git.Merge.mergeNonInteractive branch) <||> resolveMerge branch
 	godirect currbranch = do
 		old <- inRepo $ Git.Ref.sha currbranch
 		d <- fromRepo gitAnnexMergeDir
-		r <- inRepo (mergeDirect d branch) <||> resolveMerge
+		r <- inRepo (mergeDirect d branch) <||> resolveMerge branch
 		new <- inRepo $ Git.Ref.sha currbranch
 		case (old, new) of
 			(Just oldsha, Just newsha) ->
@@ -352,11 +353,11 @@ mergeFrom branch = do
  - staged to the index, and written to the gitAnnexMergeDir, and later
  - mergeDirectCleanup handles updating the work tree.
  -}
-resolveMerge :: Annex Bool
-resolveMerge = do
+resolveMerge :: Git.Ref -> Annex Bool
+resolveMerge branch = do
 	top <- fromRepo Git.repoPath
 	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
-	mergedfs <- catMaybes <$> mapM resolveMerge' fs
+	mergedfs <- catMaybes <$> mapM (resolveMerge' branch) fs
 	let merged = not (null mergedfs)
 	void $ liftIO cleanup
 
@@ -378,8 +379,8 @@ resolveMerge = do
 		showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
 	return merged
 
-resolveMerge' :: LsFiles.Unmerged -> Annex (Maybe FilePath)
-resolveMerge' u
+resolveMerge' :: Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
+resolveMerge' branch u
 	| mergeable LsFiles.valUs && mergeable LsFiles.valThem = do
 		kus <- getKey LsFiles.valUs
 		kthem <- getKey LsFiles.valThem
@@ -429,21 +430,10 @@ resolveMerge' u
 	-- removing the conflicted file from cache clears the conflict
 	unstageoldfile = Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
 
-	{- stage an item from the direct mode merge directory -}
-	stagefromdirectmergedir item = do
-		d <- fromRepo gitAnnexMergeDir
-		l <- liftIO $ dirContentsRecursive (d </> item)
-		if null l
-			then go d (d </> item)
-			else mapM_ (go d) l
-	  where
-	  	go d f = do
-			v <- getAnnexLinkTarget f
-			let worktreef = makeRelative d f
-			case v of
-				Just target -> stageSymlink worktreef
-					=<< hashSymlink target
-				Nothing -> noop
+	{- stage an item from the direct mode merge directory, which may
+	 - be a directory with arbitrary contents -}
+	stagefromdirectmergedir item = Annex.Queue.addUpdateIndex
+		=<< fromRepo (UpdateIndex.lsSubTree branch item)
 
 {- git-merge moves conflicting files away to files
  - named something like f~HEAD or f~branch, but the
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 6d1ff2548..4ecd77363 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -15,6 +15,7 @@ module Git.UpdateIndex (
 	startUpdateIndex,
 	stopUpdateIndex,
 	lsTree,
+	lsSubTree,
 	updateIndexLine,
 	stageFile,
 	unstageFile,
@@ -74,6 +75,13 @@ lsTree (Ref x) repo streamer = do
 	void $ cleanup
   where
 	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
+lsSubTree :: Ref -> FilePath -> Repo -> Streamer
+lsSubTree (Ref x) p repo streamer = do
+	(s, cleanup) <- pipeNullSplit params repo
+	mapM_ streamer s
+	void $ cleanup
+  where
+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]
 
 {- Generates a line suitable to be fed into update-index, to add
  - a given file with a given sha. -}