diff --git a/Conflict.hs b/Conflict.hs deleted file mode 100644 --- a/Conflict.hs +++ /dev/null @@ -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 diff --git a/Environment.hs b/Environment.hs deleted file mode 100644 --- a/Environment.hs +++ /dev/null @@ -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 () diff --git a/Opts.hs b/Opts.hs deleted file mode 100644 --- a/Opts.hs +++ /dev/null @@ -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 diff --git a/PPDiff.hs b/PPDiff.hs deleted file mode 100644 --- a/PPDiff.hs +++ /dev/null @@ -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 diff --git a/Resolution.hs b/Resolution.hs deleted file mode 100644 --- a/Resolution.hs +++ /dev/null @@ -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 diff --git a/SideDiff.hs b/SideDiff.hs deleted file mode 100644 --- a/SideDiff.hs +++ /dev/null @@ -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) diff --git a/StrUtils.hs b/StrUtils.hs deleted file mode 100644 --- a/StrUtils.hs +++ /dev/null @@ -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 diff --git a/Version.hs b/Version.hs deleted file mode 100644 --- a/Version.hs +++ /dev/null @@ -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 diff --git a/git-mediate.cabal b/git-mediate.cabal --- a/git-mediate.cabal +++ b/git-mediate.cabal @@ -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 diff --git a/git-mediate.hs b/git-mediate.hs deleted file mode 100644 --- a/git-mediate.hs +++ /dev/null @@ -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 diff --git a/src/Conflict.hs b/src/Conflict.hs new file mode 100644 --- /dev/null +++ b/src/Conflict.hs @@ -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 diff --git a/src/Environment.hs b/src/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Environment.hs @@ -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 () diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/src/Opts.hs b/src/Opts.hs new file mode 100644 --- /dev/null +++ b/src/Opts.hs @@ -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 diff --git a/src/PPDiff.hs b/src/PPDiff.hs new file mode 100644 --- /dev/null +++ b/src/PPDiff.hs @@ -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 diff --git a/src/Resolution.hs b/src/Resolution.hs new file mode 100644 --- /dev/null +++ b/src/Resolution.hs @@ -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 diff --git a/src/SideDiff.hs b/src/SideDiff.hs new file mode 100644 --- /dev/null +++ b/src/SideDiff.hs @@ -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) diff --git a/src/StrUtils.hs b/src/StrUtils.hs new file mode 100644 --- /dev/null +++ b/src/StrUtils.hs @@ -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 diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -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