diff --git a/PPDiff.hs b/PPDiff.hs --- a/PPDiff.hs +++ b/PPDiff.hs @@ -15,4 +15,4 @@ ppDiff :: ColorEnable -> Diff String -> String ppDiff c (First x) = wrap c Red $ '-':x ppDiff c (Second x) = wrap c Green $ '+':x -ppDiff c (Both x _) = ' ':x +ppDiff c (Both x _) = ' ':x diff --git a/resolve-trivial-conflicts.cabal b/resolve-trivial-conflicts.cabal --- a/resolve-trivial-conflicts.cabal +++ b/resolve-trivial-conflicts.cabal @@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: resolve-trivial-conflicts -version: 0.3.0.1 +version: 0.3.0.2 synopsis: Remove trivial conflict markers in a git repository description: Remove trivial conflict markers in a git repository homepage: https://github.com/ElastiLotem/resolve-trivial-conflicts diff --git a/resolve_trivial_conflicts.hs b/resolve_trivial_conflicts.hs --- a/resolve_trivial_conflicts.hs +++ b/resolve_trivial_conflicts.hs @@ -1,5 +1,6 @@ {-# OPTIONS -O2 -Wall #-} {-# LANGUAGE FlexibleContexts, RecordWildCards #-} +module Main (main) where import Control.Applicative ((<$>)) import qualified Control.Exception as E @@ -12,10 +13,11 @@ import Data.Monoid (Monoid(..)) import qualified Data.Monoid as Monoid import PPDiff (ppDiff, ColorEnable(..)) -import System.Directory (renameFile, removeFile) +import System.Directory (renameFile, removeFile, getCurrentDirectory) import System.Environment (getProgName, getArgs, getEnv) import System.Exit (ExitCode(..)) -import System.FilePath ((<.>), ()) +import System.FilePath ((<.>), makeRelative, joinPath, splitPath) +import qualified System.FilePath as FilePath import System.Posix.IO (stdOutput) import System.Posix.Terminal (queryTerminal) import System.Process (callProcess, readProcess, readProcessWithExitCode) @@ -25,30 +27,29 @@ type LineNo = Int data Conflict = Conflict - { _lineNo :: LineNo - , _markerA :: String -- <<<<<<<.... - , _markerBase :: String -- |||||||.... - , _markerB :: String -- =======.... - , _markerEnd :: String -- >>>>>>>.... - , _linesA :: [String] - , _linesBase :: [String] - , _linesB :: [String] + { cMarkerA :: (LineNo, String) -- <<<<<<<.... + , cMarkerBase :: (LineNo, String) -- |||||||.... + , cMarkerB :: (LineNo, String) -- =======.... + , cMarkerEnd :: (LineNo, String) -- >>>>>>>.... + , cLinesA :: [String] + , cLinesBase :: [String] + , cLinesB :: [String] } deriving (Show) prettyConflict :: Conflict -> String -prettyConflict (Conflict _ markerA markerBase markerB markerEnd linesA linesBase linesB) = +prettyConflict Conflict {..} = unlines $ concat - [ markerA : linesA - , markerBase : linesBase - , markerB : linesB - , [markerEnd] + [ snd cMarkerA : cLinesA + , snd cMarkerBase : cLinesBase + , snd cMarkerB : cLinesB + , [snd cMarkerEnd] ] resolveConflict :: Conflict -> Maybe String resolveConflict Conflict{..} - | _linesA == _linesBase = Just $ unlines _linesB - | _linesB == _linesBase = Just $ unlines _linesA - | _linesA == _linesB = Just $ unlines _linesA + | cLinesA == cLinesBase = Just $ unlines cLinesB + | cLinesB == cLinesBase = Just $ unlines cLinesA + | cLinesA == cLinesB = Just $ unlines cLinesA | otherwise = Nothing breakUpToMarker :: MonadState [(LineNo, String)] m => Char -> m [(LineNo, String)] @@ -67,20 +68,19 @@ mHead <- readHead return (ls, mHead) -parseConflict :: MonadState [(LineNo, String)] m => LineNo -> String -> m Conflict -parseConflict lineNo markerA = do - (linesA , Just (_, markerBase)) <- readUpToMarker '|' - (linesBase, Just (_, markerB)) <- readUpToMarker '=' - (linesB , Just (_, markerEnd)) <- readUpToMarker '>' +parseConflict :: MonadState [(LineNo, String)] m => (LineNo, String) -> m Conflict +parseConflict markerA = do + (linesA , Just markerBase) <- readUpToMarker '|' + (linesBase, Just markerB) <- readUpToMarker '=' + (linesB , Just markerEnd) <- readUpToMarker '>' return Conflict - { _lineNo = lineNo - , _markerA = markerA - , _markerBase = markerBase - , _markerB = markerB - , _markerEnd = markerEnd - , _linesA = map snd linesA - , _linesB = map snd linesB - , _linesBase = map snd linesBase + { cMarkerA = markerA + , cMarkerBase = markerBase + , cMarkerB = markerB + , cMarkerEnd = markerEnd + , cLinesA = map snd linesA + , cLinesB = map snd linesB + , cLinesBase = map snd linesBase } parseConflicts :: String -> [Either String Conflict] @@ -93,42 +93,38 @@ tell $ map (Left . snd) ls case mMarkerA of Nothing -> return () - Just (lineNo, markerA) -> + Just markerA -> do - tell . return . Right =<< parseConflict lineNo markerA + tell . return . Right =<< parseConflict markerA loop -type SideDiff = (Side, LineNo, [Diff String]) +type SideDiff = (Side, (LineNo, String), [Diff String]) data NewContent = NewContent { _resolvedSuccessfully :: Int , _failedToResolve :: Int , _newContent :: String - , _diffs :: [SideDiff] } getConflictDiffs :: Conflict -> [SideDiff] getConflictDiffs Conflict{..} = - [ (A, _lineNo, getDiff _linesBase _linesA) | not (null _linesA) ] ++ - [ (B, _lineNo, getDiff _linesBase _linesB) | not (null _linesB) ] + [ (A, cMarkerA, getDiff cLinesBase cLinesA) | not (null cLinesA) ] ++ + [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cLinesBase cLinesB) | not (null cLinesB) ] resolveContent :: [Either String Conflict] -> NewContent resolveContent = asResult . mconcat . map go where - asResult (Monoid.Sum successes, Monoid.Sum failures, newContent, diffs) = NewContent + asResult (Monoid.Sum successes, Monoid.Sum failures, newContent) = + NewContent { _resolvedSuccessfully = successes , _failedToResolve = failures , _newContent = newContent - , _diffs = diffs } - go (Left line) = (Monoid.Sum 0, Monoid.Sum 0, unlines [line], []) + go (Left line) = (Monoid.Sum 0, Monoid.Sum 0, unlines [line]) go (Right conflict) = case resolveConflict conflict of - Nothing -> - ( Monoid.Sum 0, Monoid.Sum 1, prettyConflict conflict - , getConflictDiffs conflict - ) - Just trivialLines -> (Monoid.Sum 1, Monoid.Sum 0, trivialLines, []) + Nothing -> (Monoid.Sum 0, Monoid.Sum 1, prettyConflict conflict) + Just trivialLines -> (Monoid.Sum 1, Monoid.Sum 0, trivialLines) gitAdd :: FilePath -> IO () gitAdd fileName = @@ -191,9 +187,10 @@ | shouldDumpDiffs opts = mapM_ dumpDiff diffs | otherwise = return () where - dumpDiff (side, lineNo, diff) = + dumpDiff (side, (lineNo, marker), diff) = do - putStrLn $ filePath ++ ":" ++ show lineNo ++ ":Diff" ++ show side + putStrLn $ concat + [filePath, ":", show lineNo, ":Diff", show side, ": ", marker] putStr $ unlines $ map (ppDiff colorEnable) diff dumpAndOpenEditor :: ColorEnable -> Options -> FilePath -> [SideDiff] -> IO () @@ -207,7 +204,7 @@ do content <- parseConflicts <$> readFile fileName case resolveContent content of - NewContent successes failures newContent diffs + NewContent successes failures newContent | successes == 0 && failures == 0 -> do putStrLn $ fileName ++ ": No conflicts, git-adding" @@ -216,7 +213,7 @@ putStrLn $ concat [ fileName, ": Failed to resolve any of the " , show failures, " conflicts" ] - dumpAndOpenEditor colorEnable opts fileName diffs + doDump | otherwise -> do putStrLn $ concat @@ -230,7 +227,14 @@ removeFile bkup if failures == 0 then gitAdd fileName - else dumpAndOpenEditor colorEnable opts fileName diffs + else doDump + where + doDump = + dumpAndOpenEditor colorEnable opts fileName $ + [ cDiff + | Right conflict <- parseConflicts newContent + , cDiff <- getConflictDiffs conflict + ] stripNewline :: String -> String stripNewline x @@ -281,6 +285,20 @@ , "specified in your per-project .git/config?" ] +relativePath :: FilePath -> FilePath -> FilePath +relativePath base path + | rel /= path = rel + | revRel /= base = + joinPath $ replicate (length (splitPath revRel)) ".." + | otherwise = path + where + rel = makeRelative base path + revRel = makeRelative path base + +() :: FilePath -> FilePath -> FilePath +"." p = p +d p = d FilePath. p + main :: IO () main = do opts <- getOpts =<< getArgs @@ -293,6 +311,9 @@ statusPorcelain <- readProcess "git" ["status", "--porcelain"] stdin let rootRelativeFileNames = mapMaybe (unprefix "UU ") $ lines statusPorcelain - rootDir <- stripNewline <$> readProcess "git" ["rev-parse", "--show-toplevel"] stdin + cwd <- getCurrentDirectory + rootDir <- + relativePath cwd . stripNewline <$> + readProcess "git" ["rev-parse", "--show-toplevel"] stdin mapM_ (resolve colorEnable opts . (rootDir )) rootRelativeFileNames