git merging works

Main.hs

@@ -5,7 +5,10 @@ module Main where
 import Control.Exception
 import Control.Monad
 import Data.Bool
+import Data.Char
 import Data.Foldable
+import Data.List
+import Data.Traversable
 import Opts
 import System.Exit
 import System.FilePath
@@ -36,6 +39,59 @@ rundiff f1 f2 out = do
   unless (st `elem` [ExitSuccess, ExitFailure 1])
     $ error "diff failed for unknown reason (is GNU diffutils installed?)"
 
+gitRepoRelRoot = do
+  (path, st) <-
+    withCreateProcess
+      (proc "git" ["rev-parse", "--show-cdup"])
+        {std_in = NoStream, std_out = CreatePipe, std_err = Inherit} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) $ error "git failed"
+  let [p] = lines path
+  pure p
+
+gitUnmerged = do
+  (paths, st) <-
+    withCreateProcess
+      (proc "git" ["status", "--porcelain=v1"])
+        {std_in = NoStream, std_out = CreatePipe, std_err = Inherit} $ \_ (Just oh) _ p ->
+      (,)
+        <$> (map (drop 3) . filter ("UU " `isPrefixOf`) . lines
+               <$> hGetContents' oh)
+        <*> waitForProcess p
+  unless (st == ExitSuccess) $ error "git failed"
+  pure paths
+
+gitCheckoutMOY u my old your = do
+  (paths, st) <-
+    withCreateProcess
+      (proc "git" ["ls-files", "--unmerged", "--", u])
+        {std_in = NoStream, std_out = CreatePipe, std_err = Inherit} $ \_ (Just oh) _ p ->
+      (,)
+        <$> (sortOn snd
+               . map ((\[a, b] -> (a, b)) . take 2 . drop 1 . words)
+               . lines
+               <$> hGetContents' oh)
+        <*> waitForProcess p
+  unless (st == ExitSuccess) $ error "git failed"
+  let co (hash, _) path = do
+        st <-
+          withCreateProcess
+            (proc "git" ["cat-file", "blob", hash])
+              {std_in = NoStream, std_out = CreatePipe, std_err = Inherit} $ \_ (Just ho) _ p -> do
+            hGetContents ho >>= writeFile path . Toks.split -- TODO cfg
+            waitForProcess p
+        unless (st == ExitSuccess) . error
+          $ "failed checking out " ++ u ++ " from blob " ++ hash
+  case paths of
+    [(_, "1"), (_, "2"), (_, "3")] ->
+      zipWithM co paths [old, my, your] >> pure ()
+    _ -> error $ "bad data from ls-files for unmerged " ++ u
+
+gitAdd path = do
+  traceM $ "adding " ++ path
+  st <- rawSystem "git" ["add", "--", path]
+  unless (st == ExitSuccess) $ error "git-add failed"
+
 data Op
   = Del
   | Keep
@@ -125,6 +181,14 @@ resolve _ x = x
 -- separate/overlapped conflict resolution -- e.g., what if someone wants to
 -- merge overlapping edits in text but separate edits in spaces? At this point
 -- that might be ignorable.
+--
+-- Also, conflicts that are made out of an ignorable space change and a
+-- mergeable non-space change now cause conflicts because the spaces are no
+-- longer truly separable/alignable here. Ideally some part of the space
+-- merging should be done at alignment (e.g., fake all spaces to cause them to
+-- align well). Also it might be necessary to group space-tokens together
+-- (newline and indent are now 2 space tokens, which won't ever merge with a
+-- single space)
 resolveSpace Config {..} c@(Conflict m o y)
   | m == o && o == y = Ok o
   | otherwise =
@@ -140,21 +204,22 @@ resolveSpaces _ x = x
 merge cfg@Config {..} ms ys =
   regroup
     . map (resolve cfg)
+    . traceShowId
     . regroup
     . bool id (concatMap zeal) cfgZealous
     . expand cfgContext
     . regroup
     $ align ms ys
 
-format :: Config -> [Merged] -> IO Bool
-format Config {..} = go False
+format :: Config -> Handle -> [Merged] -> IO Bool
+format Config {..} h = go False
   where
     go c [] = pure c
     go c (Ok x:xs) = do
-      putStr (Toks.glueToks x)
+      hPutStr h (Toks.glueToks x)
       go c xs
     go c (Conflict m o y:xs) = do
-      putStr
+      hPutStr h
         $ mconcat
             [ cfgLabelStart
             , Toks.glueToks m
@@ -174,11 +239,36 @@ runCmd CmdDiff3 {..} cfg =
       readFile path >>= writeFile tmp . Toks.split -- TODO cfg
     rundiff fOld fMy fdMy
     rundiff fOld fYour fdYour
-    conflicted <- merge cfg <$> pdiff fdMy <*> pdiff fdYour >>= format cfg
+    conflicted <-
+      merge cfg <$> pdiff fdMy <*> pdiff fdYour >>= format cfg stdout
     if conflicted
       then exitWith (ExitFailure 1)
       else exitSuccess
-runCmd _ _ = error "not implemented yet"
+runCmd CmdGitMerge {..} cfg = do
+  relroot <- gitRepoRelRoot
+  unmerged <-
+    case gmFiles of
+      Nothing -> map (relroot </>) <$> gitUnmerged
+      Just fs -> pure fs
+  conflicts <-
+    for unmerged $ \u ->
+      withSystemTempDirectory "werge-git" $ \workdir -> do
+        let [fMy, fOld, fYour, fdMy, fdYour] =
+              map (workdir </>) ["my", "old", "your", "mydiff", "yourdiff"]
+        gitCheckoutMOY u fMy fOld fYour
+        rundiff fOld fMy fdMy
+        rundiff fOld fYour fdYour
+        readFile u >>= writeFile (u ++ ".werge-backup")
+        conflict <-
+          withFile u WriteMode $ \h ->
+            merge cfg <$> pdiff fdMy <*> pdiff fdYour >>= format cfg h
+        traceShowM conflict
+        traceShowM gmDoAdd
+        unless conflict $ when gmDoAdd $ gitAdd u
+        pure conflict
+  if or conflicts
+    then exitWith (ExitFailure 1)
+    else exitSuccess
 
 main :: IO ()
 main = catch go bad

Opts.hs

@@ -143,9 +143,9 @@ data Command
       , d3old :: FilePath
       , d3your :: FilePath
       }
-  | CmdGitMergetool
-      { gmtFiles :: Maybe [FilePath]
-      , gmtDoAdd :: Bool
+  | CmdGitMerge
+      { gmFiles :: Maybe [FilePath]
+      , gmDoAdd :: Bool
       }
   deriving (Show)
 
@@ -156,31 +156,33 @@ cmdDiff3 = do
     strArgument $ metavar "YOURFILE" <> help "version with other people's edits"
   pure CmdDiff3 {..}
 
-cmdGitMergetool = do
-  gmtFiles <-
+cmdGitMerge = do
+  gmFiles <-
     asum
-      [ fmap Just . many
+      [ fmap Just . some
           $ strArgument
           $ metavar "UNMERGED"
-              <> help "unmerged git file (can be specified repeatedly"
+              <> help "unmerged git file (can be specified repeatedly)"
       , flag'
           Nothing
           (long "unmerged"
              <> short 'u'
              <> help "process all files marked as unmerged by git")
       ]
-  gmtDoAdd <-
+  gmDoAdd <-
     asum
       [ flag'
-          False
+          True
           (long "add"
              <> short 'a'
              <> help "run `git add' for fully merged files")
-      , flag' True (long "no-add" <> help "prevent running `git add'")
+      , flag' False (long "no-add" <> help "prevent running `git add'")
       , pure False
       ]
-  pure CmdGitMergetool {..}
+  pure CmdGitMerge {..}
 
+-- TODO have some option to output the (partially merged) my/old/your files so
+-- that folks can continue with external program or so (such as meld)
 cmd =
   hsubparser
     $ mconcat
@@ -188,7 +190,7 @@ cmd =
             $ info cmdDiff3
             $ progDesc "diff3-style merge of changes"
         , command "git"
-            $ info cmdGitMergetool
+            $ info cmdGitMerge
             $ progDesc "try to merge unmerged git tree"
         ]
 

Toks.hs

@@ -21,7 +21,7 @@ markSpace s@(c:_)
 
 unmarkSpace ('.':s) = s
 unmarkSpace ('|':s) = s
-unmarkSpace _ = error "wat"
+unmarkSpace x = error "unwat"
 
 space ('.':_) = True
 space _ = False