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 _ (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.2 +version: 0.3.1 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 @@ -22,9 +22,12 @@ executable resolve-trivial-conflicts main-is: resolve_trivial_conflicts.hs + ghc-options: -rtsopts -Wall + ghc-prof-options: -rtsopts -Wall -auto-all -caf-all other-modules: PPDiff -- other-extensions: build-depends: base >=4.6 && <5 + , base-compat >= 0.8.2 && < 0.9 , mtl >=2.1 , directory >=1.2 , process >=1.2 diff --git a/resolve_trivial_conflicts.hs b/resolve_trivial_conflicts.hs --- a/resolve_trivial_conflicts.hs +++ b/resolve_trivial_conflicts.hs @@ -1,16 +1,15 @@ {-# OPTIONS -O2 -Wall #-} -{-# LANGUAGE FlexibleContexts, RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RecordWildCards #-} module Main (main) where -import Control.Applicative ((<$>)) import qualified Control.Exception as E -import Control.Monad (when, unless) +import Control.Monad (when, unless, filterM) import Control.Monad.State (MonadState, state, evalStateT) import Control.Monad.Writer (runWriter, tell) import Data.Algorithm.Diff (Diff, getDiff) +import Data.Foldable (asum, traverse_) import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (mapMaybe) -import Data.Monoid (Monoid(..)) import qualified Data.Monoid as Monoid import PPDiff (ppDiff, ColorEnable(..)) import System.Directory (renameFile, removeFile, getCurrentDirectory) @@ -18,10 +17,13 @@ import System.Exit (ExitCode(..)) import System.FilePath ((<.>), makeRelative, joinPath, splitPath) import qualified System.FilePath as FilePath +import qualified System.Posix.Files as PosixFiles import System.Posix.IO (stdOutput) import System.Posix.Terminal (queryTerminal) import System.Process (callProcess, readProcess, readProcessWithExitCode) +import Prelude.Compat + data Side = A | B deriving (Eq, Ord, Show) type LineNo = Int @@ -52,8 +54,15 @@ | cLinesA == cLinesB = Just $ unlines cLinesA | otherwise = Nothing +-- '>' -> ">>>>>>> " +markerPrefix :: Char -> String +markerPrefix c = replicate 7 c ++ " " + +markerLine :: Char -> String -> String +markerLine c str = markerPrefix c ++ str ++ "\n" + breakUpToMarker :: MonadState [(LineNo, String)] m => Char -> m [(LineNo, String)] -breakUpToMarker c = state (break ((replicate 7 c `isPrefixOf`) . snd)) +breakUpToMarker c = state (break ((markerPrefix c `isPrefixOf`) . snd)) readHead :: MonadState [a] m => m (Maybe a) readHead = state f @@ -71,7 +80,7 @@ parseConflict :: MonadState [(LineNo, String)] m => (LineNo, String) -> m Conflict parseConflict markerA = do (linesA , Just markerBase) <- readUpToMarker '|' - (linesBase, Just markerB) <- readUpToMarker '=' + (linesBase, Just markerB) <- readUpToMarker '=' (linesB , Just markerEnd) <- readUpToMarker '>' return Conflict { cMarkerA = markerA @@ -199,6 +208,15 @@ dumpDiffs colorEnable opts path diffs openEditor opts path +overwrite :: FilePath -> String -> IO () +overwrite fileName newContent = + do + renameFile fileName bkup + writeFile fileName newContent + removeFile bkup + where + bkup = fileName <.> "bk" + resolve :: ColorEnable -> Options -> FilePath -> IO () resolve colorEnable opts fileName = do @@ -221,16 +239,13 @@ , " conflicts (failed to resolve " ++ show failures ++ " conflicts)" , if failures == 0 then ", git adding" else "" ] - let bkup = fileName <.> "bk" - renameFile fileName bkup - writeFile fileName newContent - removeFile bkup + overwrite fileName newContent if failures == 0 then gitAdd fileName else doDump where doDump = - dumpAndOpenEditor colorEnable opts fileName $ + dumpAndOpenEditor colorEnable opts fileName [ cDiff | Right conflict <- parseConflicts newContent , cDiff <- getConflictDiffs conflict @@ -299,6 +314,68 @@ "." p = p d p = d FilePath. p +isDirectory :: FilePath -> IO Bool +isDirectory x = PosixFiles.isDirectory <$> PosixFiles.getFileStatus x + +ensureNewline :: String -> String +ensureNewline "" = "" +ensureNewline str = str ++ suffix + where + suffix + | "\n" `isSuffixOf` str = "" + | otherwise = "\n" + +withAllStageFiles :: + FilePath -> (FilePath -> Maybe FilePath -> Maybe FilePath -> IO b) -> IO b +withAllStageFiles path action = + do + let stdin = "" + [baseTmp, localTmp, remoteTmp] <- + take 3 . words <$> + readProcess "git" ["checkout-index", "--stage=all", "--", path] stdin + let maybePath "." = Nothing + maybePath p = Just p + let mLocalTmp = maybePath localTmp + mRemoteTmp = maybePath remoteTmp + action baseTmp mLocalTmp mRemoteTmp + `E.finally` + do + removeFile baseTmp + traverse_ removeFile mLocalTmp + traverse_ removeFile mRemoteTmp + +deleteModifyConflictAddMarkers :: FilePath -> IO () +deleteModifyConflictAddMarkers path = + withAllStageFiles path $ \baseTmp mLocalTmp mRemoteTmp -> + do + baseContent <- readFile baseTmp + localContent <- maybe (return "") readFile mLocalTmp + remoteContent <- maybe (return "") readFile mRemoteTmp + overwrite path $ + concat + [ markerLine '<' "LOCAL" + , ensureNewline localContent + , markerLine '|' "BASE" + , ensureNewline baseContent + , markerLine '=' "" + , ensureNewline remoteContent + , markerLine '>' "REMOTE" + ] + +deleteModifyConflictHandle :: FilePath -> IO () +deleteModifyConflictHandle path = + do notMarked <- null . filter (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path + when notMarked $ + do putStrLn $ show path ++ " has a delete/modify conflict. Adding conflict markers" + deleteModifyConflictAddMarkers path + +removeFileIfEmpty :: FilePath -> IO () +removeFileIfEmpty path = + do isEmpty <- null <$> readFile path + when isEmpty $ + do removeFile path + callProcess "git" ["add", "-u", "--", path] + main :: IO () main = do opts <- getOpts =<< getArgs @@ -309,11 +386,32 @@ checkConflictStyle opts let stdin = "" statusPorcelain <- readProcess "git" ["status", "--porcelain"] stdin - let rootRelativeFileNames = - mapMaybe (unprefix "UU ") $ lines statusPorcelain cwd <- getCurrentDirectory rootDir <- relativePath cwd . stripNewline <$> readProcess "git" ["rev-parse", "--show-toplevel"] stdin - mapM_ (resolve colorEnable opts . - (rootDir )) rootRelativeFileNames + let rootRelativeFiles = + filterM (fmap not . isDirectory) . map (rootDir ) + let firstMatchingPrefix :: [String] -> String -> Maybe String + firstMatchingPrefix prefixes = + asum . traverse unprefix prefixes + let filesMatchingPrefixes :: [String] -> IO [FilePath] + filesMatchingPrefixes prefixes = + rootRelativeFiles . mapMaybe (firstMatchingPrefix prefixes) + $ lines statusPorcelain + +-- from git-diff manpage: +-- Added (A), Copied (C), Deleted (D), Modified (M), Renamed (R), +-- have their type (i.e. regular file, symlink, submodule, ...) changed (T), +-- are Unmerged (U), are Unknown (X), or have had their pairing Broken (B) + + deleteModifyConflicts <- filesMatchingPrefixes ["DU ", "UD "] + + mapM_ deleteModifyConflictHandle deleteModifyConflicts + + filesMatchingPrefixes ["UU ", "AA ", "DA ", "AD ", "DU ", "UD "] + >>= mapM_ (resolve colorEnable opts) + + -- Heuristically delete files that were remove/modify conflict + -- and ended up with empty content + mapM_ removeFileIfEmpty deleteModifyConflicts