resolve-trivial-conflicts 0.3.0.2 → 0.3.1
raw patch · 3 files changed
+118/−17 lines, 3 filesdep +base-compat
Dependencies added: base-compat
Files
- PPDiff.hs +1/−1
- resolve-trivial-conflicts.cabal +4/−1
- resolve_trivial_conflicts.hs +113/−15
PPDiff.hs view
@@ -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
resolve-trivial-conflicts.cabal view
@@ -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
resolve_trivial_conflicts.hs view
@@ -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