git-mediate 1.0.3 → 1.0.4
raw patch · 19 files changed
+607/−604 lines, 19 filesdep +unix-compatdep −unixdep ~base-compat
Dependencies added: unix-compat
Dependencies removed: unix
Dependency ranges changed: base-compat
Files
- Conflict.hs +0/−98
- Environment.hs +0/−64
- Opts.hs +0/−72
- PPDiff.hs +0/−18
- Resolution.hs +0/−46
- SideDiff.hs +0/−26
- StrUtils.hs +0/−27
- Version.hs +0/−8
- git-mediate.cabal +6/−5
- git-mediate.hs +0/−240
- src/Conflict.hs +98/−0
- src/Environment.hs +64/−0
- src/Main.hs +242/−0
- src/Opts.hs +72/−0
- src/PPDiff.hs +18/−0
- src/Resolution.hs +46/−0
- src/SideDiff.hs +26/−0
- src/StrUtils.hs +27/−0
- src/Version.hs +8/−0
− Conflict.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, RecordWildCards #-}--module Conflict- ( Conflict(..), LineNo- , prettyConflict, prettyConflictLines- , parseConflicts- , markerPrefix- ) where--import Control.Monad.State (MonadState, state, evalStateT)-import Control.Monad.Writer (runWriter, tell)-import Data.List (isPrefixOf)--import Prelude.Compat--type LineNo = Int--data Conflict = Conflict- { cMarkerA :: (LineNo, String) -- <<<<<<<....- , cMarkerBase :: (LineNo, String) -- |||||||....- , cMarkerB :: (LineNo, String) -- =======....- , cMarkerEnd :: (LineNo, String) -- >>>>>>>....- , cLinesA :: [String]- , cLinesBase :: [String]- , cLinesB :: [String]- } deriving (Show)--prettyConflictLines :: Conflict -> [String]-prettyConflictLines Conflict {..} =- concat- [ snd cMarkerA : cLinesA- , snd cMarkerBase : cLinesBase- , snd cMarkerB : cLinesB- , [snd cMarkerEnd]- ]--prettyConflict :: Conflict -> String-prettyConflict = unlines . prettyConflictLines---- '>' -> ">>>>>>>"-markerPrefix :: Char -> String-markerPrefix = replicate 7--breakUpToMarker :: MonadState [(LineNo, String)] m => Char -> m [(LineNo, String)]-breakUpToMarker c = state (break ((markerPrefix c `isPrefixOf`) . snd))--readHead :: MonadState [a] m => m (Maybe a)-readHead = state f- where- f [] = (Nothing, [])- f (l:ls) = (Just l, ls)--tryReadUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], Maybe (LineNo, String))-tryReadUpToMarker c =- do- ls <- breakUpToMarker c- mHead <- readHead- return (ls, mHead)--readUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], (LineNo, String))-readUpToMarker c = do- res <- tryReadUpToMarker c- case res of- (ls, Just h) -> return (ls, h)- (ls, Nothing) ->- error $ concat- [ "Parse error: failed reading up to marker: "- , show c, ", got:"- , concatMap (\(l,s) -> "\n" ++ show l ++ "\t" ++ s) $ take 5 ls- ]--parseConflict :: MonadState [(LineNo, String)] m => (LineNo, String) -> m Conflict-parseConflict markerA =- do (linesA , markerBase) <- readUpToMarker '|'- (linesBase, markerB) <- readUpToMarker '='- (linesB , markerEnd) <- readUpToMarker '>'- return Conflict- { 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]-parseConflicts input =- snd $ runWriter $ evalStateT loop (zip [1..] (lines input))- where- loop =- do (ls, mMarkerA) <- tryReadUpToMarker '<'- tell $ map (Left . snd) ls- case mMarkerA of- Nothing -> return ()- Just markerA ->- do tell . return . Right =<< parseConflict markerA- loop
− Environment.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Environment- ( checkConflictStyle, shouldUseColorByTerminal, openEditor- ) where--import qualified Control.Exception as E-import Control.Monad (when, unless)-import Opts (Options(..))-import PPDiff (ColorEnable(..))-import StrUtils (stripNewline)-import System.Environment (getEnv)-import System.Exit (ExitCode(..))-import System.Posix.IO (stdOutput)-import System.Posix.Terminal (queryTerminal)-import System.Process (callProcess, readProcessWithExitCode)--import Prelude.Compat--shouldUseColorByTerminal :: IO ColorEnable-shouldUseColorByTerminal =- do istty <- queryTerminal stdOutput- return $ if istty then EnableColor else DisableColor--getConflictStyle :: IO String-getConflictStyle =- do (exitCode, stdout, _) <- readProcessWithExitCode "git" ["config", "merge.conflictstyle"] stdin- case exitCode of- ExitSuccess -> return $ stripNewline stdout- ExitFailure 1 -> return "unset"- ExitFailure _ -> E.throwIO exitCode- where- stdin = ""--setConflictStyle :: IO ()-setConflictStyle =- callProcess "git" ["config", "--global", "merge.conflictstyle", "diff3"]--checkConflictStyle :: Options -> IO ()-checkConflictStyle opts =- do conflictStyle <- getConflictStyle- when (conflictStyle /= "diff3") $- do unless (shouldSetConflictStyle opts) $- fail $ concat- [ "merge.conflictstyle must be diff3 but is "- , show conflictStyle- , ". Use -s to automatically set it globally"- ]- setConflictStyle-- newConflictStyle <- getConflictStyle- when (newConflictStyle /= "diff3") $- fail $ concat- [ "Attempt to set conflict style failed. Perhaps you have"- , " an incorrect merge.conflictstyle configuration "- , "specified in your per-project .git/config?"- ]--openEditor :: Options -> FilePath -> IO ()-openEditor opts path- | shouldUseEditor opts =- do editor <- getEnv "EDITOR"- callProcess editor [path]- | otherwise = return ()
− Opts.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE LambdaCase #-}--- | Option parser--module Opts- ( Options(..)- , getOpts- ) where--import Control.Applicative (Alternative(..))-import Data.Monoid ((<>))-import qualified Options.Applicative as O-import PPDiff (ColorEnable(..))-import System.Exit (exitSuccess)-import Version (versionString)--data Options = Options- { shouldUseEditor :: Bool- , shouldDumpDiffs :: Bool- , shouldDumpDiff2 :: Bool- , shouldUseColor :: Maybe ColorEnable- , shouldSetConflictStyle :: Bool- }--data CmdArgs = CmdVersion | CmdOptions Options--parser :: O.Parser CmdArgs-parser =- O.flag' CmdVersion (O.long "version" <> O.help "Print the version and quit")- <|> CmdOptions- <$> ( Options- <$> O.switch- ( O.long "editor" <> O.short 'e'- <> O.help "Execute $EDITOR for each conflicted file that remains conflicted"- )- <*> O.switch- ( O.long "diff" <> O.short 'd'- <> O.help "Dump the left/right diffs from base in each conflict remaining"- )- <*> O.switch- ( O.long "diff2" <> O.short '2'- <> O.help "Dump the diff between left and right in each conflict remaining"- )- <*> ( O.flag' (Just EnableColor)- (O.long "color" <> O.short 'c' <> O.help "Enable color")- <|> O.flag' (Just DisableColor)- (O.long "no-color" <> O.short 'C' <> O.help "Disable color")- <|> pure Nothing- )- <*> O.switch- ( O.long "style" <> O.short 's'- <> O.help "Configure git's global merge.conflictstyle to diff3 if needed"- )- )--opts :: O.ParserInfo CmdArgs-opts =- O.info (O.helper <*> parser) $- O.fullDesc- <> O.progDesc- "Resolve any git conflicts that have become trivial by editing operations.\n\- \Go to http://github.com/Peaker/git-mediate for example use."- <> O.header "git-mediate - Become a conflicts hero"--getOpts :: IO Options-getOpts =- O.execParser opts- >>= \case- CmdVersion ->- do- putStrLn $ "git-mediate version " ++ versionString- exitSuccess- CmdOptions o -> return o
− PPDiff.hs
@@ -1,18 +0,0 @@-module PPDiff- ( ColorEnable(..)- , ppDiff- ) where--import Data.Algorithm.Diff (Diff(..))-import System.Console.ANSI--data ColorEnable = EnableColor | DisableColor--wrap :: ColorEnable -> Color -> String -> String-wrap DisableColor _ str = str-wrap EnableColor color str = setSGRCode [SetColor Foreground Vivid color] ++ str ++ setSGRCode [Reset]--ppDiff :: ColorEnable -> Diff String -> String-ppDiff c (First x) = wrap c Red $ '-':x-ppDiff c (Second x) = wrap c Green $ '+':x-ppDiff _ (Both x _) = ' ':x
− Resolution.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-}--module Resolution- ( Resolution(..)- , resolveConflict- ) where--import Conflict (Conflict(..), prettyConflictLines)--import Prelude.Compat--data Resolution- = NoResolution- | Resolution String- | PartialResolution String--resolveConflict :: Conflict -> Resolution-resolveConflict conflict@Conflict{..}- | cLinesA == cLinesBase = Resolution $ unlines cLinesB- | cLinesB == cLinesBase = Resolution $ unlines cLinesA- | cLinesA == cLinesB = Resolution $ unlines cLinesA- | matchTop > 0 || matchBottom > 0 =- PartialResolution $ unlines $- take matchTop cLinesBase ++- prettyConflictLines conflict- { cLinesA = unmatched cLinesA- , cLinesBase = unmatched cLinesBase- , cLinesB = unmatched cLinesB- } ++- takeEnd matchBottom cLinesBase- | otherwise = NoResolution- where- matchTop =- minimum $ map (lengthOfCommonPrefix cLinesBase) [cLinesA, cLinesB]- revBottom = reverse . drop matchTop- revBottomBase = revBottom cLinesBase- matchBottom =- minimum $- map (lengthOfCommonPrefix revBottomBase . revBottom)- [cLinesA, cLinesB]- dropEnd count xs = take (length xs - count) xs- takeEnd count xs = drop (length xs - count) xs- unmatched xs = drop matchTop $ dropEnd matchBottom xs--lengthOfCommonPrefix :: Eq a => [a] -> [a] -> Int-lengthOfCommonPrefix x y = length $ takeWhile id $ zipWith (==) x y
− SideDiff.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-}--module SideDiff- ( SideDiff, Side(..)- , getConflictDiffs, getConflictDiff2s- ) where--import Conflict (Conflict(..), LineNo)-import Data.Algorithm.Diff (Diff, getDiff)--import Prelude.Compat--data Side = A | B- deriving (Eq, Ord, Show)--type SideDiff = (Side, (LineNo, String), [Diff String])--getConflictDiffs :: Conflict -> [SideDiff]-getConflictDiffs Conflict{..} =- [ (A, cMarkerA, getDiff cLinesBase cLinesA)- | not (null cLinesA) ] ++- [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cLinesBase cLinesB)- | not (null cLinesB) ]--getConflictDiff2s :: Conflict -> ((LineNo, String), (LineNo, String), [Diff String])-getConflictDiff2s Conflict{..} = (cMarkerA, cMarkerB, getDiff cLinesA cLinesB)
− StrUtils.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module StrUtils- ( stripNewline, ensureNewline, unprefix- ) where--import Data.List (isPrefixOf, isSuffixOf)--import Prelude.Compat--stripNewline :: String -> String-stripNewline x- | "\n" `isSuffixOf` x = init x- | otherwise = x--ensureNewline :: String -> String-ensureNewline "" = ""-ensureNewline str = str ++ suffix- where- suffix- | "\n" `isSuffixOf` str = ""- | otherwise = "\n"--unprefix :: Eq a => [a] -> [a] -> Maybe [a]-unprefix prefix str- | prefix `isPrefixOf` str = Just (drop (length prefix) str)- | otherwise = Nothing
− Version.hs
@@ -1,8 +0,0 @@--- | Expose cabal package version as a string-module Version (versionString) where--import Paths_git_mediate (version)-import Data.Version (showVersion)--versionString :: String-versionString = showVersion version
git-mediate.cabal view
@@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: git-mediate-version: 1.0.3+version: 1.0.4 synopsis: Remove trivial conflict markers in a git repository description: Remove trivial conflict markers in a git repository homepage: https://github.com/Peaker/git-mediate@@ -21,7 +21,7 @@ location: https://github.com/Peaker/git-mediate executable git-mediate- main-is: git-mediate.hs+ main-is: Main.hs other-modules: Conflict , Environment , Opts@@ -30,17 +30,18 @@ , SideDiff , StrUtils , Version+ , Paths_git_mediate ghc-options: -O2 -Wall -- other-extensions: build-depends: base >=4.8 && <5- , base-compat >= 0.8.2 && < 0.10+ , base-compat >= 0.8.2 && < 0.11 , mtl >=2.1 , directory >=1.2 , process >=1.2 , filepath >=1.3- , unix >=2.7+ , unix-compat >=0.4.2.0 , Diff >=0.3 , ansi-terminal >=0.6.2 , optparse-applicative >=0.11 && <0.15- -- hs-source-dirs:+ hs-source-dirs: src default-language: Haskell2010
− git-mediate.hs
@@ -1,240 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, LambdaCase #-}--module Main (main) where--import Conflict (Conflict(..), prettyConflict, parseConflicts, markerPrefix)-import qualified Control.Exception as E-import Control.Monad (when, unless, filterM)-import Data.Foldable (asum, traverse_)-import Data.List (isPrefixOf)-import Data.Maybe (mapMaybe)-import qualified Data.Monoid as Monoid-import Environment (checkConflictStyle, openEditor, shouldUseColorByTerminal)-import qualified Opts-import Opts (Options(..))-import PPDiff (ppDiff, ColorEnable(..))-import Resolution (Resolution(..), resolveConflict)-import SideDiff (getConflictDiffs, getConflictDiff2s)-import StrUtils (ensureNewline, stripNewline, unprefix)-import System.Directory (renameFile, removeFile, getCurrentDirectory)-import System.Exit (ExitCode(..), exitWith)-import System.FilePath ((<.>), makeRelative, joinPath, splitPath)-import qualified System.FilePath as FilePath-import System.IO (hPutStr, stderr)-import qualified System.Posix.Files as PosixFiles-import System.Process (callProcess, readProcess, readProcessWithExitCode)--import Prelude.Compat--markerLine :: Char -> String -> String-markerLine c str = markerPrefix c ++ " " ++ str ++ "\n"--data NewContent = NewContent- { _resolvedSuccessfully :: Int- , _reducedConflicts :: Int- , _failedToResolve :: Int- , _newContent :: String- }--resolveContent :: [Either String Conflict] -> NewContent-resolveContent =- asResult . mconcat . map go- where- asResult (Monoid.Sum successes, Monoid.Sum reductions, Monoid.Sum failures, newContent) =- NewContent- { _resolvedSuccessfully = successes- , _reducedConflicts = reductions- , _failedToResolve = failures- , _newContent = newContent- }- go (Left line) = (Monoid.Sum 0, Monoid.Sum 0, Monoid.Sum 0, unlines [line])- go (Right conflict) =- case resolveConflict conflict of- NoResolution -> (Monoid.Sum 0, Monoid.Sum 0, Monoid.Sum 1, prettyConflict conflict)- Resolution trivialLines -> (Monoid.Sum 1, Monoid.Sum 0, Monoid.Sum 0, trivialLines)- PartialResolution newLines -> (Monoid.Sum 0, Monoid.Sum 1, Monoid.Sum 0, newLines)--gitAdd :: FilePath -> IO ()-gitAdd fileName =- callProcess "git" ["add", "--", fileName]--dumpDiffs :: ColorEnable -> Options -> FilePath -> [Conflict] -> IO ()-dumpDiffs colorEnable opts filePath conflicts =- do- when (shouldDumpDiffs opts) $ mapM_ dumpDiff $ concatMap getConflictDiffs conflicts- when (shouldDumpDiff2 opts) $ mapM_ (dumpDiff2 . getConflictDiff2s) conflicts- where- dumpDiff (side, (lineNo, marker), diff) =- do putStrLn $ concat- [filePath, ":", show lineNo, ":Diff", show side, ": ", marker]- putStr $ unlines $ map (ppDiff colorEnable) diff- dumpDiff2 ((lineNoA, markerA), (lineNoB, markerB), diff) =- do putStrLn $ concat [filePath, ":", show lineNoA, " <->", markerA]- putStrLn $ concat [filePath, ":", show lineNoB, ": ", markerB]- putStr $ unlines $ map (ppDiff colorEnable) diff--dumpAndOpenEditor :: ColorEnable -> Options -> FilePath -> [Conflict] -> IO ()-dumpAndOpenEditor colorEnable opts path conflicts =- do dumpDiffs colorEnable opts path conflicts- 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 =- resolveContent . parseConflicts <$> readFile fileName- >>= \case- NewContent successes reductions failures newContent- | successes == 0 && allGood ->- do putStrLn $ fileName ++ ": No conflicts, git-adding"- gitAdd fileName- | successes == 0 && reductions == 0 ->- do putStrLn $ concat- [ fileName, ": Failed to resolve any of the "- , show failures, " conflicts" ]- doDump- | successes == 0 ->- do putStrLn $ concat- [ fileName, ": Reduced ", show reductions, " conflicts"]- overwrite fileName newContent- doDump- | otherwise ->- do putStrLn $ concat- [ fileName, ": Successfully resolved ", show successes- , " conflicts (failed to resolve " ++ show (reductions + failures) ++ " conflicts)"- , if allGood then ", git adding" else ""- ]- overwrite fileName newContent- if allGood- then gitAdd fileName- else doDump- where- allGood = failures == 0 && reductions == 0- doDump =- dumpAndOpenEditor colorEnable opts fileName- [ conflict | Right conflict <- parseConflicts newContent ]--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--isDirectory :: FilePath -> IO Bool-isDirectory x = PosixFiles.isDirectory <$> PosixFiles.getFileStatus x--withAllStageFiles ::- FilePath -> (FilePath -> Maybe FilePath -> Maybe FilePath -> IO b) -> IO b-withAllStageFiles path action =- do let stdin = ""- [baseTmpRaw, localTmpRaw, remoteTmpRaw] <-- take 3 . words <$>- readProcess "git" ["checkout-index", "--stage=all", "--", path] stdin- cdup <-- takeWhile (/= '\0') . stripNewline <$>- readProcess "git" ["rev-parse", "--show-cdup"] stdin- let maybePath "." = Nothing- maybePath p = Just (cdup </> p)- let mLocalTmp = maybePath localTmpRaw- mRemoteTmp = maybePath remoteTmpRaw- baseTmp = cdup </> baseTmpRaw- 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 marked <- any (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path- unless marked $- 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]--getStatusPorcelain :: IO String-getStatusPorcelain =- do (statusCode, statusPorcelain, statusStderr) <-- readProcessWithExitCode "git" ["status", "--porcelain"] ""- when (statusCode /= ExitSuccess) $ do- -- Print git's error message. Usually -- -- "fatal: Not a git repository (or any of the parent directories): .git"- hPutStr stderr statusStderr- exitWith statusCode- return statusPorcelain--main :: IO ()-main =- do opts <- Opts.getOpts- colorEnable <-- case shouldUseColor opts of- Nothing -> shouldUseColorByTerminal- Just colorEnable -> return colorEnable- checkConflictStyle opts- statusPorcelain <- getStatusPorcelain- cwd <- getCurrentDirectory- rootDir <-- relativePath cwd . stripNewline <$>- readProcess "git" ["rev-parse", "--show-toplevel"] ""- 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
+ src/Conflict.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, RecordWildCards #-}++module Conflict+ ( Conflict(..), LineNo+ , prettyConflict, prettyConflictLines+ , parseConflicts+ , markerPrefix+ ) where++import Control.Monad.State (MonadState, state, evalStateT)+import Control.Monad.Writer (runWriter, tell)+import Data.List (isPrefixOf)++import Prelude.Compat++type LineNo = Int++data Conflict = Conflict+ { cMarkerA :: (LineNo, String) -- <<<<<<<....+ , cMarkerBase :: (LineNo, String) -- |||||||....+ , cMarkerB :: (LineNo, String) -- =======....+ , cMarkerEnd :: (LineNo, String) -- >>>>>>>....+ , cLinesA :: [String]+ , cLinesBase :: [String]+ , cLinesB :: [String]+ } deriving (Show)++prettyConflictLines :: Conflict -> [String]+prettyConflictLines Conflict {..} =+ concat+ [ snd cMarkerA : cLinesA+ , snd cMarkerBase : cLinesBase+ , snd cMarkerB : cLinesB+ , [snd cMarkerEnd]+ ]++prettyConflict :: Conflict -> String+prettyConflict = unlines . prettyConflictLines++-- '>' -> ">>>>>>>"+markerPrefix :: Char -> String+markerPrefix = replicate 7++breakUpToMarker :: MonadState [(LineNo, String)] m => Char -> m [(LineNo, String)]+breakUpToMarker c = state (break ((markerPrefix c `isPrefixOf`) . snd))++readHead :: MonadState [a] m => m (Maybe a)+readHead = state f+ where+ f [] = (Nothing, [])+ f (l:ls) = (Just l, ls)++tryReadUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], Maybe (LineNo, String))+tryReadUpToMarker c =+ do+ ls <- breakUpToMarker c+ mHead <- readHead+ return (ls, mHead)++readUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], (LineNo, String))+readUpToMarker c = do+ res <- tryReadUpToMarker c+ case res of+ (ls, Just h) -> return (ls, h)+ (ls, Nothing) ->+ error $ concat+ [ "Parse error: failed reading up to marker: "+ , show c, ", got:"+ , concatMap (\(l,s) -> "\n" ++ show l ++ "\t" ++ s) $ take 5 ls+ ]++parseConflict :: MonadState [(LineNo, String)] m => (LineNo, String) -> m Conflict+parseConflict markerA =+ do (linesA , markerBase) <- readUpToMarker '|'+ (linesBase, markerB) <- readUpToMarker '='+ (linesB , markerEnd) <- readUpToMarker '>'+ return Conflict+ { 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]+parseConflicts input =+ snd $ runWriter $ evalStateT loop (zip [1..] (lines input))+ where+ loop =+ do (ls, mMarkerA) <- tryReadUpToMarker '<'+ tell $ map (Left . snd) ls+ case mMarkerA of+ Nothing -> return ()+ Just markerA ->+ do tell . return . Right =<< parseConflict markerA+ loop
+ src/Environment.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Environment+ ( checkConflictStyle, shouldUseColorByTerminal, openEditor+ ) where++import qualified Control.Exception as E+import Control.Monad (when, unless)+import Opts (Options(..))+import PPDiff (ColorEnable(..))+import StrUtils (stripNewline)+import System.Console.ANSI (hSupportsANSI)+import System.IO (stdout)+import System.Environment (getEnv)+import System.Exit (ExitCode(..))+import System.Process (callProcess, readProcessWithExitCode)++import Prelude.Compat++shouldUseColorByTerminal :: IO ColorEnable+shouldUseColorByTerminal =+ do istty <- hSupportsANSI stdout+ return $ if istty then EnableColor else DisableColor++getConflictStyle :: IO String+getConflictStyle =+ do (exitCode, output, _) <- readProcessWithExitCode "git" ["config", "merge.conflictstyle"] stdin+ case exitCode of+ ExitSuccess -> return $ stripNewline output+ ExitFailure 1 -> return "unset"+ ExitFailure _ -> E.throwIO exitCode+ where+ stdin = ""++setConflictStyle :: IO ()+setConflictStyle =+ callProcess "git" ["config", "--global", "merge.conflictstyle", "diff3"]++checkConflictStyle :: Options -> IO ()+checkConflictStyle opts =+ do conflictStyle <- getConflictStyle+ when (conflictStyle /= "diff3") $+ do unless (shouldSetConflictStyle opts) $+ fail $ concat+ [ "merge.conflictstyle must be diff3 but is "+ , show conflictStyle+ , ". Use -s to automatically set it globally"+ ]+ setConflictStyle++ newConflictStyle <- getConflictStyle+ when (newConflictStyle /= "diff3") $+ fail $ concat+ [ "Attempt to set conflict style failed. Perhaps you have"+ , " an incorrect merge.conflictstyle configuration "+ , "specified in your per-project .git/config?"+ ]++openEditor :: Options -> FilePath -> IO ()+openEditor opts path+ | shouldUseEditor opts =+ do editor <- getEnv "EDITOR"+ callProcess editor [path]+ | otherwise = return ()
+ src/Main.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE NoImplicitPrelude, LambdaCase #-}++module Main (main) where++import Conflict (Conflict(..), prettyConflict, parseConflicts, markerPrefix)+import qualified Control.Exception as E+import Control.Monad (when, unless, filterM)+import Data.Foldable (asum, traverse_)+import Data.List (isPrefixOf)+import Data.Maybe (mapMaybe)+import qualified Data.Monoid as Monoid+import Environment (checkConflictStyle, openEditor, shouldUseColorByTerminal)+import qualified Opts+import Opts (Options(..))+import PPDiff (ppDiff, ColorEnable(..))+import Resolution (Resolution(..), resolveConflict)+import SideDiff (getConflictDiffs, getConflictDiff2s)+import StrUtils (ensureNewline, stripNewline, unprefix)+import System.Directory (renameFile, removeFile, getCurrentDirectory)+import System.Exit (ExitCode(..), exitWith)+import System.FilePath ((<.>), makeRelative, joinPath, splitPath)+import qualified System.FilePath as FilePath+import System.IO (hPutStr, stderr)+import qualified System.PosixCompat.Files as PosixFiles+import System.Process (callProcess, readProcess, readProcessWithExitCode)++import Prelude.Compat++markerLine :: Char -> String -> String+markerLine c str = markerPrefix c ++ " " ++ str ++ "\n"++data NewContent = NewContent+ { _resolvedSuccessfully :: Int+ , _reducedConflicts :: Int+ , _failedToResolve :: Int+ , _newContent :: String+ }++resolveContent :: [Either String Conflict] -> NewContent+resolveContent =+ asResult . mconcat . map go+ where+ asResult (Monoid.Sum successes, Monoid.Sum reductions, Monoid.Sum failures, newContent) =+ NewContent+ { _resolvedSuccessfully = successes+ , _reducedConflicts = reductions+ , _failedToResolve = failures+ , _newContent = newContent+ }+ go (Left line) = (Monoid.Sum 0, Monoid.Sum 0, Monoid.Sum 0, unlines [line])+ go (Right conflict) =+ case resolveConflict conflict of+ NoResolution -> (Monoid.Sum 0, Monoid.Sum 0, Monoid.Sum 1, prettyConflict conflict)+ Resolution trivialLines -> (Monoid.Sum 1, Monoid.Sum 0, Monoid.Sum 0, trivialLines)+ PartialResolution newLines -> (Monoid.Sum 0, Monoid.Sum 1, Monoid.Sum 0, newLines)++gitAdd :: FilePath -> IO ()+gitAdd fileName =+ callProcess "git" ["add", "--", fileName]++dumpDiffs :: ColorEnable -> Options -> FilePath -> Int -> (Int, Conflict) -> IO ()+dumpDiffs colorEnable opts filePath count (idx, conflict) =+ do+ putStrLn $ unwords ["### Conflict", show idx, "of", show count]+ when (shouldDumpDiffs opts) $ mapM_ dumpDiff $ getConflictDiffs conflict+ when (shouldDumpDiff2 opts) $ dumpDiff2 $ getConflictDiff2s conflict+ where+ dumpDiff (side, (lineNo, marker), diff) =+ do putStrLn $ concat+ [filePath, ":", show lineNo, ":Diff", show side, ": ", marker]+ putStr $ unlines $ map (ppDiff colorEnable) diff+ dumpDiff2 ((lineNoA, markerA), (lineNoB, markerB), diff) =+ do putStrLn $ concat [filePath, ":", show lineNoA, " <->", markerA]+ putStrLn $ concat [filePath, ":", show lineNoB, ": ", markerB]+ putStr $ unlines $ map (ppDiff colorEnable) diff++dumpAndOpenEditor :: ColorEnable -> Options -> FilePath -> [Conflict] -> IO ()+dumpAndOpenEditor colorEnable opts path conflicts =+ do when (shouldDumpDiffs opts || shouldDumpDiff2 opts) $+ mapM_ (dumpDiffs colorEnable opts path (length conflicts)) (zip [1..] conflicts)+ 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 =+ resolveContent . parseConflicts <$> readFile fileName+ >>= \case+ NewContent successes reductions failures newContent+ | successes == 0 && allGood ->+ do putStrLn $ fileName ++ ": No conflicts, git-adding"+ gitAdd fileName+ | successes == 0 && reductions == 0 ->+ do putStrLn $ concat+ [ fileName, ": Failed to resolve any of the "+ , show failures, " conflicts" ]+ doDump+ | successes == 0 ->+ do putStrLn $ concat+ [ fileName, ": Reduced ", show reductions, " conflicts"]+ overwrite fileName newContent+ doDump+ | otherwise ->+ do putStrLn $ concat+ [ fileName, ": Successfully resolved ", show successes+ , " conflicts (failed to resolve " ++ show (reductions + failures) ++ " conflicts)"+ , if allGood then ", git adding" else ""+ ]+ overwrite fileName newContent+ if allGood+ then gitAdd fileName+ else doDump+ where+ allGood = failures == 0 && reductions == 0+ doDump =+ dumpAndOpenEditor colorEnable opts fileName+ [ conflict | Right conflict <- parseConflicts newContent ]++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++isDirectory :: FilePath -> IO Bool+isDirectory x = PosixFiles.isDirectory <$> PosixFiles.getFileStatus x++withAllStageFiles ::+ FilePath -> (FilePath -> Maybe FilePath -> Maybe FilePath -> IO b) -> IO b+withAllStageFiles path action =+ do let stdin = ""+ [baseTmpRaw, localTmpRaw, remoteTmpRaw] <-+ take 3 . words <$>+ readProcess "git" ["checkout-index", "--stage=all", "--", path] stdin+ cdup <-+ takeWhile (/= '\0') . stripNewline <$>+ readProcess "git" ["rev-parse", "--show-cdup"] stdin+ let maybePath "." = Nothing+ maybePath p = Just (cdup </> p)+ let mLocalTmp = maybePath localTmpRaw+ mRemoteTmp = maybePath remoteTmpRaw+ baseTmp = cdup </> baseTmpRaw+ 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 marked <- any (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path+ unless marked $+ 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]++getStatusPorcelain :: IO String+getStatusPorcelain =+ do (statusCode, statusPorcelain, statusStderr) <-+ readProcessWithExitCode "git" ["status", "--porcelain"] ""+ when (statusCode /= ExitSuccess) $ do+ -- Print git's error message. Usually -+ -- "fatal: Not a git repository (or any of the parent directories): .git"+ hPutStr stderr statusStderr+ exitWith statusCode+ return statusPorcelain++main :: IO ()+main =+ do opts <- Opts.getOpts+ colorEnable <-+ case shouldUseColor opts of+ Nothing -> shouldUseColorByTerminal+ Just colorEnable -> return colorEnable+ checkConflictStyle opts+ statusPorcelain <- getStatusPorcelain+ cwd <- getCurrentDirectory+ rootDir <-+ relativePath cwd . stripNewline <$>+ readProcess "git" ["rev-parse", "--show-toplevel"] ""+ 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
+ src/Opts.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE LambdaCase #-}+-- | Option parser++module Opts+ ( Options(..)+ , getOpts+ ) where++import Control.Applicative (Alternative(..))+import Data.Monoid ((<>))+import qualified Options.Applicative as O+import PPDiff (ColorEnable(..))+import System.Exit (exitSuccess)+import Version (versionString)++data Options = Options+ { shouldUseEditor :: Bool+ , shouldDumpDiffs :: Bool+ , shouldDumpDiff2 :: Bool+ , shouldUseColor :: Maybe ColorEnable+ , shouldSetConflictStyle :: Bool+ }++data CmdArgs = CmdVersion | CmdOptions Options++parser :: O.Parser CmdArgs+parser =+ O.flag' CmdVersion (O.long "version" <> O.help "Print the version and quit")+ <|> CmdOptions+ <$> ( Options+ <$> O.switch+ ( O.long "editor" <> O.short 'e'+ <> O.help "Execute $EDITOR for each conflicted file that remains conflicted"+ )+ <*> O.switch+ ( O.long "diff" <> O.short 'd'+ <> O.help "Dump the left/right diffs from base in each conflict remaining"+ )+ <*> O.switch+ ( O.long "diff2" <> O.short '2'+ <> O.help "Dump the diff between left and right in each conflict remaining"+ )+ <*> ( O.flag' (Just EnableColor)+ (O.long "color" <> O.short 'c' <> O.help "Enable color")+ <|> O.flag' (Just DisableColor)+ (O.long "no-color" <> O.short 'C' <> O.help "Disable color")+ <|> pure Nothing+ )+ <*> O.switch+ ( O.long "style" <> O.short 's'+ <> O.help "Configure git's global merge.conflictstyle to diff3 if needed"+ )+ )++opts :: O.ParserInfo CmdArgs+opts =+ O.info (O.helper <*> parser) $+ O.fullDesc+ <> O.progDesc+ "Resolve any git conflicts that have become trivial by editing operations.\n\+ \Go to http://github.com/Peaker/git-mediate for example use."+ <> O.header "git-mediate - Become a conflicts hero"++getOpts :: IO Options+getOpts =+ O.execParser opts+ >>= \case+ CmdVersion ->+ do+ putStrLn $ "git-mediate version " ++ versionString+ exitSuccess+ CmdOptions o -> return o
+ src/PPDiff.hs view
@@ -0,0 +1,18 @@+module PPDiff+ ( ColorEnable(..)+ , ppDiff+ ) where++import Data.Algorithm.Diff (Diff(..))+import System.Console.ANSI++data ColorEnable = EnableColor | DisableColor++wrap :: ColorEnable -> Color -> String -> String+wrap DisableColor _ str = str+wrap EnableColor color str = setSGRCode [SetColor Foreground Vivid color] ++ str ++ setSGRCode [Reset]++ppDiff :: ColorEnable -> Diff String -> String+ppDiff c (First x) = wrap c Red $ '-':x+ppDiff c (Second x) = wrap c Green $ '+':x+ppDiff _ (Both x _) = ' ':x
+ src/Resolution.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-}++module Resolution+ ( Resolution(..)+ , resolveConflict+ ) where++import Conflict (Conflict(..), prettyConflictLines)++import Prelude.Compat++data Resolution+ = NoResolution+ | Resolution String+ | PartialResolution String++resolveConflict :: Conflict -> Resolution+resolveConflict conflict@Conflict{..}+ | cLinesA == cLinesBase = Resolution $ unlines cLinesB+ | cLinesB == cLinesBase = Resolution $ unlines cLinesA+ | cLinesA == cLinesB = Resolution $ unlines cLinesA+ | matchTop > 0 || matchBottom > 0 =+ PartialResolution $ unlines $+ take matchTop cLinesBase +++ prettyConflictLines conflict+ { cLinesA = unmatched cLinesA+ , cLinesBase = unmatched cLinesBase+ , cLinesB = unmatched cLinesB+ } +++ takeEnd matchBottom cLinesBase+ | otherwise = NoResolution+ where+ matchTop =+ minimum $ map (lengthOfCommonPrefix cLinesBase) [cLinesA, cLinesB]+ revBottom = reverse . drop matchTop+ revBottomBase = revBottom cLinesBase+ matchBottom =+ minimum $+ map (lengthOfCommonPrefix revBottomBase . revBottom)+ [cLinesA, cLinesB]+ dropEnd count xs = take (length xs - count) xs+ takeEnd count xs = drop (length xs - count) xs+ unmatched xs = drop matchTop $ dropEnd matchBottom xs++lengthOfCommonPrefix :: Eq a => [a] -> [a] -> Int+lengthOfCommonPrefix x y = length $ takeWhile id $ zipWith (==) x y
+ src/SideDiff.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-}++module SideDiff+ ( SideDiff, Side(..)+ , getConflictDiffs, getConflictDiff2s+ ) where++import Conflict (Conflict(..), LineNo)+import Data.Algorithm.Diff (Diff, getDiff)++import Prelude.Compat++data Side = A | B+ deriving (Eq, Ord, Show)++type SideDiff = (Side, (LineNo, String), [Diff String])++getConflictDiffs :: Conflict -> [SideDiff]+getConflictDiffs Conflict{..} =+ [ (A, cMarkerA, getDiff cLinesBase cLinesA)+ | not (null cLinesA) ] +++ [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cLinesBase cLinesB)+ | not (null cLinesB) ]++getConflictDiff2s :: Conflict -> ((LineNo, String), (LineNo, String), [Diff String])+getConflictDiff2s Conflict{..} = (cMarkerA, cMarkerB, getDiff cLinesA cLinesB)
+ src/StrUtils.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE NoImplicitPrelude #-}++module StrUtils+ ( stripNewline, ensureNewline, unprefix+ ) where++import Data.List (isPrefixOf, isSuffixOf)++import Prelude.Compat++stripNewline :: String -> String+stripNewline x+ | "\n" `isSuffixOf` x = init x+ | otherwise = x++ensureNewline :: String -> String+ensureNewline "" = ""+ensureNewline str = str ++ suffix+ where+ suffix+ | "\n" `isSuffixOf` str = ""+ | otherwise = "\n"++unprefix :: Eq a => [a] -> [a] -> Maybe [a]+unprefix prefix str+ | prefix `isPrefixOf` str = Just (drop (length prefix) str)+ | otherwise = Nothing
+ src/Version.hs view
@@ -0,0 +1,8 @@+-- | Expose cabal package version as a string+module Version (versionString) where++import Paths_git_mediate (version)+import Data.Version (showVersion)++versionString :: String+versionString = showVersion version