diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,13 @@ -## 1.0.9 / To be released +## 1.1.0 / 2024.09.20 + +* `--split-markers` option to help users split large conflicts to smaller parts +* `--lines-added-around` option to auto-resolve conflicts of line added from different sides +* Command-line options are are also parsed from the `GIT_MEDIATE_OPTIONS` environment variables +* Can disable auto-resolution with the `--no-trivial`, `--no-reduce`, and `--no-line-endings` flags +* Improved `--editor` support for VS Code and Xcode +* Fixed handling of filenames containing spaces and special characters + +## 1.0.9 / 2023.07.25 * Do not warn when git is set to use `zdiff3` conflict style * Resolve line ending conventions changes (i.e changes from Unix/Windows line endings) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -75,12 +75,17 @@ # Installation -## Recommended: Using haskell-stack +## Using package managers +* macOS: `brew install git-mediate` +* Linux (debian): `apt-get install git-mediate` + +## Using haskell-stack + 1. Install [haskell stack](https://docs.haskellstack.org/en/stable/) 2. Run: `stack install git-mediate` -## Alternative install: from sources +## From sources Clone it: 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 https://cabal.readthedocs.io/ name: git-mediate -version: 1.0.9 +version: 1.1.0 synopsis: Tool to help resolving git conflicts description: Git conflict resolution has never been easier . @@ -63,17 +63,21 @@ main-is: Main.hs other-modules: Conflict , Environment + , Git , Opts + , OptUtils , PPDiff , Resolution + , ResolutionOpts , SideDiff , StrUtils , Version , Paths_git_mediate ghc-options: -O2 -Wall -- other-extensions: - build-depends: base >=4.8 && <5 + build-depends: base >=4.16 && <5 , base-compat >= 0.8.2 + , containers , mtl >=2.1 , directory >=1.2 , process >=1.2 @@ -83,5 +87,6 @@ , ansi-terminal >=0.6.2 , optparse-applicative >=0.11 , generic-data >=0.8.2 + , split hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Conflict.hs b/src/Conflict.hs --- a/src/Conflict.hs +++ b/src/Conflict.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, DeriveTraversable, NamedFieldPuns, DerivingVia, DeriveGeneric, OverloadedRecordDot #-} +{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, DeriveTraversable, NamedFieldPuns #-} +{-# LANGUAGE DerivingVia, DeriveGeneric, OverloadedRecordDot, LambdaCase #-} module Conflict ( Conflict(..), Sides(..), SrcContent(..) @@ -7,11 +8,11 @@ , parse ) where -import Control.Monad.State (MonadState, state, evalStateT) +import Control.Monad.State (MonadState, evalStateT, state) import Control.Monad.Writer (runWriter, tell) import Data.Maybe (fromMaybe) -import Generic.Data (Generically1(..)) import GHC.Generics (Generic1) +import Generic.Data (Generically1(..)) import Prelude.Compat @@ -19,19 +20,22 @@ { sideA :: a , sideBase :: a , sideB :: a - } deriving (Functor, Foldable, Traversable, Show, Eq, Ord, Generic1) - deriving Applicative via Generically1 Sides + } + deriving (Functor, Foldable, Traversable, Show, Eq, Ord, Generic1) + deriving (Applicative) via Generically1 Sides data SrcContent = SrcContent { lineNo :: Int , content :: String - } deriving Show + } + deriving (Show) data Conflict = Conflict - { markers :: Sides SrcContent -- The markers at the beginning of sections - , markerEnd :: SrcContent -- The ">>>>>>>...." marker at the end of the conflict - , bodies :: Sides [String] - } deriving Show + { markers :: Sides SrcContent -- The markers at the beginning of sections + , markerEnd :: SrcContent -- The ">>>>>>>...." marker at the end of the conflict + , bodies :: Sides [String] + } + deriving (Show) setBodies :: (Sides [String] -> Sides [String]) -> Conflict -> Conflict setBodies f c = c{bodies = f c.bodies} @@ -44,7 +48,7 @@ prettyLines :: Conflict -> [String] prettyLines c = - concat ((:) <$> ((.content) <$> c.markers) <*> c.bodies) <> [c.markerEnd.content] + concat ((:) . content <$> c.markers <*> c.bodies) <> [c.markerEnd.content] pretty :: Conflict -> String pretty = unlines . prettyLines @@ -81,20 +85,21 @@ readUpToMarker :: MonadState [SrcContent] m => Char -> Maybe Int -> m ([SrcContent], SrcContent) -readUpToMarker c mCount = do - res <- tryReadUpToMarker c mCount - case res of - (ls, Just h) -> pure (ls, h) - (ls, Nothing) -> - error $ concat - [ "Parse error: failed reading up to marker: " - , show c, ", got:" - , concatMap (\l -> "\n" ++ show l.lineNo ++ "\t" ++ l.content) $ take 5 ls - ] +readUpToMarker c mCount = + tryReadUpToMarker c mCount >>= + \case + (ls, Just h) -> pure (ls, h) + (ls, Nothing) -> + error $ concat + [ "Parse error: failed reading up to marker: " + , show c, ", got:" + , concatMap (\l -> "\n" ++ show l.lineNo ++ "\t" ++ l.content) $ take 5 ls + ] parseConflict :: MonadState [SrcContent] m => SrcContent -> m Conflict parseConflict markerA = - do (linesA , markerBase) <- readUpToMarker '|' markerCount + do + (linesA, markerBase) <- readUpToMarker '|' markerCount (linesBase, markerB) <- readUpToMarker '=' markerCount (linesB , markerEnd) <- readUpToMarker '>' markerCount pure Conflict @@ -110,13 +115,15 @@ snd . runWriter . evalStateT loop where loop = - do (ls, mMarkerA) <- tryReadUpToMarker '<' Nothing + do + (ls, mMarkerA) <- tryReadUpToMarker '<' Nothing tell $ map (Left . (.content)) ls case mMarkerA of Nothing -> pure () Just markerA -> - do tell . pure . Right =<< parseConflict markerA + do + tell . pure . Right =<< parseConflict markerA loop parse :: String -> [Either String Conflict] -parse = parseFromNumberedLines . zipWith SrcContent [1..] . lines +parse = parseFromNumberedLines . zipWith SrcContent [1 ..] . lines diff --git a/src/Environment.hs b/src/Environment.hs --- a/src/Environment.hs +++ b/src/Environment.hs @@ -25,7 +25,8 @@ getConflictStyle :: IO String getConflictStyle = - do (exitCode, output, _) <- readProcessWithExitCode "git" ["config", "merge.conflictstyle"] stdin + do + (exitCode, output, _) <- readProcessWithExitCode "git" ["config", "merge.conflictstyle"] stdin case exitCode of ExitSuccess -> pure $ stripNewline output ExitFailure 1 -> pure "unset" @@ -39,9 +40,11 @@ checkConflictStyle :: Options -> IO () checkConflictStyle opts = - do conflictStyle <- getConflictStyle + do + conflictStyle <- getConflictStyle unless (conflictStyle `elem` ["diff3", "zdiff3"]) $ - do unless opts.shouldSetConflictStyle $ + do + unless opts.shouldSetConflictStyle $ fail $ concat [ "merge.conflictstyle must be diff3 but is " , show conflictStyle @@ -60,10 +63,12 @@ openEditor :: Options -> FilePath -> Int -> IO () openEditor opts path lineNo | opts.shouldUseEditor = - do editor <- getEnv "EDITOR" + do + editor <- getEnv "EDITOR" let cmdOpts = case editor of "code" -> ["--goto", path <> ":" <> show lineNo] + "xed" -> ["-l", show lineNo, path] _ -> ["+" <> show lineNo, path] callProcess editor cmdOpts | otherwise = pure () diff --git a/src/Git.hs b/src/Git.hs new file mode 100644 --- /dev/null +++ b/src/Git.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE NoImplicitPrelude, OverloadedRecordDot #-} + +module Git + ( StatusLine(..), StatusCode, getStatus, getRootDir, getCdUp, add + , makeFilesMatchingPrefixes + ) where + +import Control.Monad (when, filterM) +import Data.Foldable (asum) +import Data.List.Split (splitOn) +import Data.Maybe (mapMaybe) +import StrUtils ((), stripNewline) +import System.Directory (getCurrentDirectory) +import System.Exit (ExitCode(..), exitWith) +import System.FilePath (makeRelative, joinPath, splitPath) +import System.IO (hPutStr, stderr) +import qualified System.PosixCompat.Files as PosixFiles +import System.Process (callProcess, readProcess, readProcessWithExitCode) + +import Prelude.Compat + +type StatusCode = (Char, Char) + +data StatusLine = StatusLine + { statusCode :: StatusCode + , statusArgs :: String + } + +parseStatusZ :: [String] -> Either String [StatusLine] +parseStatusZ [""] = Right [] +parseStatusZ (('R':' ':dst):_src:rest) = + -- We don't currently do anything with rename statuses so _src is ignored + (StatusLine ('R', ' ') dst :) <$> parseStatusZ rest +-- TODO: Which other statuses have two fields? +parseStatusZ ((x:y:' ':arg):rest) = (StatusLine (x, y) arg :) <$> parseStatusZ rest +parseStatusZ part = Left ("Cannot parse status -z part: " <> show part) + +getStatus :: IO [StatusLine] +getStatus = + do + (resCode, statusZ, statusStderr) <- + readProcessWithExitCode "git" ["status", "-z"] "" + when (resCode /= ExitSuccess) $ do + -- Print git's error message. Usually - + -- "fatal: Not a git repository (or any of the parent directories): .git" + hPutStr stderr statusStderr + exitWith resCode + case parseStatusZ $ splitOn "\0" statusZ of + Right res -> pure res + Left err -> + do + hPutStr stderr err + exitWith (ExitFailure 1) + +getRootDir :: IO FilePath +getRootDir = + do + cwd <- getCurrentDirectory + relativePath cwd . stripNewline + <$> readProcess "git" ["rev-parse", "--show-toplevel"] "" + +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 + +add :: FilePath -> IO () +add fileName = callProcess "git" ["add", "--", fileName] + +-- TODO: Is this different from getRootDir? +getCdUp :: IO FilePath +getCdUp = takeWhile (/= '\0') . stripNewline <$> readProcess "git" ["rev-parse", "--show-cdup"] "" + +makeFilesMatchingPrefixes :: IO ([Git.StatusCode] -> IO [FilePath]) +makeFilesMatchingPrefixes = + do + statusPorcelain <- Git.getStatus + rootDir <- Git.getRootDir + let rootRelativeFiles = + filterM (fmap not . isDirectory) . map (rootDir ) + let decode x = + case reads x of + [(r, "")] -> r + _ -> x + let firstMatchingStatus :: [Git.StatusCode] -> Git.StatusLine -> Maybe String + firstMatchingStatus statuses = + fmap decode . asum . traverse matchStatus statuses + let filesMatchingStatuses :: [Git.StatusCode] -> IO [FilePath] + filesMatchingStatuses statuses = + rootRelativeFiles . mapMaybe (firstMatchingStatus statuses) + $ statusPorcelain + pure filesMatchingStatuses + +matchStatus :: Git.StatusCode -> Git.StatusLine -> Maybe String +matchStatus code line + | line.statusCode == code = Just line.statusArgs + | otherwise = Nothing + +isDirectory :: FilePath -> IO Bool +isDirectory x = PosixFiles.isDirectory <$> PosixFiles.getFileStatus x diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -5,27 +5,25 @@ import Conflict (Conflict(..)) import qualified Conflict import qualified Control.Exception as E -import Control.Monad (when, unless, filterM) +import Control.Monad (when, unless) import Data.Algorithm.Diff (Diff, PolyDiff(..)) import Data.Either (rights) -import Data.Foldable (asum, traverse_) +import Data.Foldable (traverse_) import Data.List (isPrefixOf) -import Data.Maybe (mapMaybe) import Environment (checkConflictStyle, openEditor, shouldUseColorByTerminal) +import qualified Git import qualified Opts import Opts (Options(..)) import PPDiff (ppDiff, ColorEnable(..)) -import Resolution (Result(..), NewContent(..), Untabify(..)) +import Resolution (Result(..), NewContent(..)) import qualified Resolution +import qualified ResolutionOpts import SideDiff (SideDiff(..), getConflictDiffs, getConflictDiff2s) -import StrUtils (ensureNewline, stripNewline, unprefix) -import System.Directory (renameFile, removeFile, getCurrentDirectory, getPermissions, setPermissions) +import StrUtils ((), ensureNewline) +import System.Directory (renameFile, removeFile, getPermissions, setPermissions) 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 System.FilePath ((<.>)) +import System.Process (callProcess, readProcess) import Prelude.Compat @@ -36,10 +34,6 @@ markerLine :: Char -> String -> String markerLine c str = markerPrefix c ++ " " ++ str ++ "\n" -gitAdd :: FilePath -> IO () -gitAdd fileName = - callProcess "git" ["add", "--", fileName] - trimDiff :: Int -> [Diff a] -> [Diff a] trimDiff contextLen = reverse . f . reverse . f @@ -56,23 +50,27 @@ when opts.shouldDumpDiff2 $ dumpDiff2 $ getConflictDiff2s conflict where dumpDiff d = - do putStrLn $ concat + do + putStrLn $ concat [filePath, ":", show d.marker.lineNo, ":Diff", show d.side, ": ", d.marker.content] - putStr $ unlines $ map (ppDiff colorEnable) (trimDiff opts.diffsContext d.diff) + putStr $ unlines $ map (ppDiff colorEnable) (trimDiff opts.envOptions.diffsContext d.diff) dumpDiff2 (markerA, markerB, d) = - do putStrLn $ concat [filePath, ":", show markerA.lineNo, " <->", markerA.content] + do + putStrLn $ concat [filePath, ":", show markerA.lineNo, " <->", markerA.content] putStrLn $ concat [filePath, ":", show markerB.lineNo, ": ", markerB.content] putStr $ unlines $ map (ppDiff colorEnable) d dumpAndOpenEditor :: ColorEnable -> Options -> FilePath -> [Conflict] -> IO () dumpAndOpenEditor colorEnable opts path conflicts = - do when (opts.shouldDumpDiffs || opts.shouldDumpDiff2) $ - traverse_ (dumpDiffs colorEnable opts path (length conflicts)) (zip [1..] conflicts) + do + when (opts.shouldDumpDiffs || opts.shouldDumpDiff2) $ + traverse_ (dumpDiffs colorEnable opts path (length conflicts)) (zip [1 ..] conflicts) openEditor opts path ((Conflict.lineNo . Conflict.sideA . markers . head) conflicts) overwrite :: FilePath -> String -> IO () overwrite fileName content = - do oldPermissions <- getPermissions fileName + do + oldPermissions <- getPermissions fileName renameFile fileName bkup writeFile fileName content setPermissions fileName oldPermissions @@ -83,28 +81,36 @@ handleFileResult :: ColorEnable -> Options -> FilePath -> NewContent -> IO () handleFileResult colorEnable opts fileName res | successes == 0 && allGood = - do putStrLn $ fileName ++ ": No conflicts, git-adding" - gitAdd fileName + do + putStrLn $ fileName ++ ": No conflicts, git-adding" + Git.add fileName | successes == 0 && reductions == 0 = - do putStrLn $ concat - [ fileName, ": Failed to resolve any of the " - , show failures, " conflicts" ] - doDump + do + putStrLn $ concat + [ fileName + , if ResolutionOpts.isResolving opts.envOptions.resolution + then ": Failed to resolve any of the " else ": " + , show failures + , " conflicts" + ] + doDump | successes == 0 = - do putStrLn $ concat - [ fileName, ": Reduced ", show reductions, " conflicts"] - overwrite fileName res.newContent - doDump + do + putStrLn $ concat + [fileName, ": Reduced ", show reductions, " conflicts"] + overwrite fileName res.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 res.newContent - if allGood - then gitAdd fileName - else doDump + do + putStrLn $ concat + [ fileName, ": Successfully resolved ", show successes + , " conflicts (failed to resolve ", show (reductions + failures), " conflicts)" + , if allGood then ", git adding" else "" + ] + overwrite fileName res.newContent + if allGood + then Git.add fileName + else doDump where allGood = Resolution.fullySuccessful res.result doDump = @@ -120,53 +126,35 @@ resolve colorEnable opts fileName = do resolutions <- - Resolution.resolveContent (Untabify opts.untabify) + Resolution.resolveContent opts.envOptions.resolution . Conflict.parse <$> readFile fileName resolutions.result <$ handleFileResult colorEnable opts fileName resolutions -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 = "" + do [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 + take 3 . words + <$> readProcess "git" ["checkout-index", "--stage=all", "--", path] "" + cdup <- Git.getCdUp 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 + `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 + do + baseContent <- readFile baseTmp localContent <- foldMap readFile mLocalTmp remoteContent <- foldMap readFile mRemoteTmp overwrite path $ @@ -182,75 +170,51 @@ deleteModifyConflictHandle :: FilePath -> IO () deleteModifyConflictHandle path = - do marked <- + do + marked <- any (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path unless marked $ - do putStrLn $ show path ++ " has a delete/modify conflict. Adding conflict markers" + do + putStrLn $ show path ++ " has a delete/modify conflict. Adding conflict markers" deleteModifyConflictAddMarkers path removeFileIfEmpty :: FilePath -> IO () removeFileIfEmpty path = - do isEmpty <- null <$> readFile path + do + isEmpty <- null <$> readFile path when isEmpty $ - do removeFile path + 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 - pure statusPorcelain - -getGitRootDir :: IO FilePath -getGitRootDir = - do cwd <- getCurrentDirectory - relativePath cwd . stripNewline <$> - readProcess "git" ["rev-parse", "--show-toplevel"] "" - -makeFilesMatchingPrefixes :: IO ([String] -> IO [FilePath]) -makeFilesMatchingPrefixes = - do statusPorcelain <- getStatusPorcelain - rootDir <- getGitRootDir - let rootRelativeFiles = - filterM (fmap not . isDirectory) . map (rootDir ) - let decode x = - case reads x of - [(r, "")] -> r - _ -> x - let firstMatchingPrefix :: [String] -> String -> Maybe String - firstMatchingPrefix prefixes = - fmap decode . asum . traverse unprefix prefixes - let filesMatchingPrefixes :: [String] -> IO [FilePath] - filesMatchingPrefixes prefixes = - rootRelativeFiles . mapMaybe (firstMatchingPrefix prefixes) - $ lines statusPorcelain - pure filesMatchingPrefixes +statusCodes :: Char -> Char -> [Git.StatusCode] +statusCodes x y + | x == y = [(x, y)] + | otherwise = [(x, y), (y, x)] mediateAll :: ColorEnable -> Options -> IO Result mediateAll colorEnable opts = - do filesMatchingPrefixes <- makeFilesMatchingPrefixes + do + filesMatchingPrefixes <- Git.makeFilesMatchingPrefixes --- 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) + -- 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 "] + deleteModifyConflicts <- filesMatchingPrefixes (statusCodes 'D' 'U') - traverse_ deleteModifyConflictHandle deleteModifyConflicts + traverse_ deleteModifyConflictHandle deleteModifyConflicts - res <- filesMatchingPrefixes ["UU ", "AA ", "DA ", "AD ", "DU ", "UD "] - >>= foldMap (resolve colorEnable opts) + res <- + filesMatchingPrefixes + ([('U', 'U'), ('A', 'A'), ('D', 'A'), ('D', 'U')] >>= uncurry statusCodes) + >>= foldMap (resolve colorEnable opts) - -- Heuristically delete files that were remove/modify conflict - -- and ended up with empty content - traverse_ removeFileIfEmpty deleteModifyConflicts - pure res + -- Heuristically delete files that were remove/modify conflict + -- and ended up with empty content + traverse_ removeFileIfEmpty deleteModifyConflicts + pure res exitCodeOf :: Result -> ExitCode exitCodeOf res @@ -262,10 +226,11 @@ main :: IO () main = - do opts <- Opts.getOpts - colorEnable <- maybe shouldUseColorByTerminal pure opts.shouldUseColor - checkConflictStyle opts - case opts.mergeSpecificFile of - Nothing -> mediateAll colorEnable opts - Just path -> resolve colorEnable opts path - >>= exitProcess + do + opts <- Opts.getOpts + colorEnable <- maybe shouldUseColorByTerminal pure opts.shouldUseColor + checkConflictStyle opts + case opts.mergeSpecificFile of + Nothing -> mediateAll colorEnable opts + Just path -> resolve colorEnable opts path + >>= exitProcess diff --git a/src/OptUtils.hs b/src/OptUtils.hs new file mode 100644 --- /dev/null +++ b/src/OptUtils.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedRecordDot, LambdaCase, FlexibleContexts #-} + +module OptUtils + ( Parser, parseEnvOptions, envSwitch, envOptional, envOption + ) where + +import Control.Applicative ((<|>)) +import Control.Monad ((>=>), guard, unless) +import Control.Monad.Reader +import Control.Monad.State +import Data.Foldable (traverse_) +import Data.Functor.Compose (Compose(..)) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import qualified Data.Set as S +import qualified Options.Applicative as O +import System.Environment (lookupEnv) +import Text.Read.Compat (readMaybe) + +type Parser = Compose (ReaderT EnvVarName (State EnvContent)) O.Parser + +type EnvVarName = String + +data EnvContent = EnvContent + { flags :: S.Set String + , options :: M.Map String String + , errors :: [String] + } + +instance Semigroup EnvContent where + EnvContent f0 o0 e0 <> EnvContent f1 o1 e1 = + EnvContent (f0 <> f1) (o0 <> o1) + ( e0 <> e1 + <> (("Duplicate flag: " <>) <$> S.toList (S.intersection f0 f1)) + <> (("Duplicate option: " <>) <$> M.keys (M.intersection o0 o1)) + ) + +instance Monoid EnvContent where + mempty = EnvContent mempty mempty mempty + +parseEnvOptions :: String -> Parser a -> IO (O.Parser a) +parseEnvOptions name (Compose parser) = + do + envOpts <- foldMap (parseEnv . words) <$> lookupEnv name + let (result, remainder) = runState (runReaderT parser name) envOpts + let errFmt = formatRemainder remainder + result <$ + unless (null errFmt) + (putStrLn (unlines + (("Warning: unhandled options in " <> name <> ":") : ((" * " <>) <$> errFmt)))) + +formatRemainder :: EnvContent -> [String] +formatRemainder (EnvContent f o e) = + (("Unrecognized flag --" <>) <$> S.toList f) + <> M.foldMapWithKey (\k v -> ["Unrecognized option: --" <> k <> " " <> v]) o + <> e + +parseEnv :: [String] -> EnvContent +parseEnv [] = mempty +parseEnv (('-':'-':flag@(_:_)):rest) = parseEnvFlag flag rest +parseEnv (['-',flag]:rest) = parseEnvFlag [flag] rest +parseEnv (other:rest) = mempty{errors = ["Unknown argument: " <> other]} <> parseEnv rest + +parseEnvFlag :: String -> [String] -> EnvContent +parseEnvFlag flag rest = + case rest of + [] -> flagRes + ('-':_):_ -> flagRes <> parseEnv rest + val:rest' -> mempty{options = M.singleton flag val} <> parseEnv rest' + where + flagRes = mempty{flags = S.singleton flag} + +-- | A boolean flag which may be initialized by an environment variable. +-- +-- If the flag is present in the environment, +-- the corresponding --no- or -- flag will be available to override it. +envSwitch :: String -> Bool -> String -> Parser Bool +envSwitch name def desc = + Compose $ + do + otherInEnv <- gets (S.member otherMode . flags) + modify (\x -> x{flags = S.delete otherMode x.flags}) + let flag + | otherInEnv = defaultMode + | otherwise = otherMode + let curDef = def /= otherInEnv + let actionHelp + | curDef = "Disable" + | otherwise = "Enable" + extraHelp <- (guard otherInEnv >>) <$> overrideHelp otherMode + let help = actionHelp <> " " <> desc <> extraHelp + pure ((/= curDef) <$> O.switch (O.long flag <> O.help help)) + where + noFlag = "no-" <> name + (defaultMode, otherMode) + | def = (name, noFlag) + | otherwise = (noFlag, name) + +overrideHelp :: MonadReader EnvVarName m => String -> m String +overrideHelp val = asks (\name -> " (override \"--" <> val <> "\" from " <> name <> ")") + +-- | An optional value which may be initialized by an environment variable. +-- +-- If the flag is present in the environment, +-- a corresponding --no- flag will be available to disable it. +envOptional :: (Read a, Show a) => String -> String -> String -> (a -> String) -> Parser (Maybe a) +envOptional name valDesc help disableHelp = + Compose $ + readOption name >>= + \case + Just val -> + do + oh <- overrideHelp (name <> " " <> show val) + ov <- envOptionFromEnv val + opt <- getCompose (envOption name Nothing (commonMods <> ov)) + pure $ + O.optional opt + <|> f <$> O.switch (O.long ("no-" <> name) <> O.help (disableHelp val <> oh)) + where + f True = Nothing + f False = Just val + Nothing -> pure (O.optional (O.option O.auto (O.long name <> commonMods))) + where + commonMods = O.metavar valDesc <> O.help help + +readOption :: (Read a, MonadState EnvContent m) => String -> m (Maybe a) +readOption name = + do + result <- gets (M.lookup name . options >=> readMaybe) + result <$ traverse_ (const (modify (\x -> x{options = M.delete name x.options}))) result + +-- | An option with a default value which may be initialized by an environment variable. +-- +-- (the default value should be specified in the provided @O.Mod@ argument) +envOption :: (Read a, Show a) => String -> Maybe Char -> O.Mod O.OptionFields a -> Parser a +envOption name shortName mods = + Compose $ + traverse readOption ([name] <> maybe [] (pure . pure) shortName) + >>= + \case + [] -> pure (O.option O.auto baseMods) + [val] -> O.option O.auto . (baseMods <>) <$> envOptionFromEnv val + _ -> + O.option O.auto baseMods <$ + modify (\x -> x{errors = x.errors <> ["Both --" <> name <> " and -" <> maybe [] pure shortName <> " specified"]}) + . catMaybes + where + baseMods = O.long name <> foldMap O.short shortName <> mods + +envOptionFromEnv :: (MonadReader EnvVarName m, Show a) => a -> m (O.Mod O.OptionFields a) +envOptionFromEnv val = + asks (\envVar -> O.value val <> O.showDefaultWith (\x -> show x <> ", from " <> envVar)) diff --git a/src/Opts.hs b/src/Opts.hs --- a/src/Opts.hs +++ b/src/Opts.hs @@ -2,13 +2,15 @@ -- | Option parser module Opts - ( Options(..) + ( Options(..), EnvOptions(..) , getOpts ) where import Control.Applicative (Alternative(..)) import qualified Options.Applicative as O +import qualified OptUtils import PPDiff (ColorEnable(..)) +import qualified ResolutionOpts as ResOpts import System.Exit (exitSuccess) import Version (versionString) @@ -18,59 +20,68 @@ , shouldDumpDiff2 :: Bool , shouldUseColor :: Maybe ColorEnable , shouldSetConflictStyle :: Bool - , untabify :: Maybe Int , mergeSpecificFile :: Maybe FilePath - , diffsContext :: Int + , envOptions :: EnvOptions } +-- Options which can be defaulted from the GIT_MEDIATE_OPTIONS environment variable +data EnvOptions = EnvOptions + { diffsContext :: Int + , resolution :: ResOpts.ResolutionOptions + } + +optionsParser :: O.Parser EnvOptions -> O.Parser Options +optionsParser envOpts = + 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" + ) + <*> colorParser + <*> O.switch + ( O.long "style" <> O.short 's' + <> O.help "Configure git's global merge.conflictstyle to diff3 if needed" + ) + <*> O.optional + ( O.strOption + ( O.long "merge-file" <> O.short 'f' <> O.help "Merge a specific file") + ) + <*> envOpts + where + colorParser = + 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 + +envOptsParser :: OptUtils.Parser EnvOptions +envOptsParser = + EnvOptions + <$> OptUtils.envOption "context" (Just 'U') + ( O.metavar "LINECOUNT" <> O.showDefault <> O.value 3 + <> O.help "Number of context lines around dumped diffs" + ) + <*> ResOpts.parser + data CmdArgs = CmdVersion | CmdOptions Options -parser :: O.Parser CmdArgs -parser = +parser :: O.Parser EnvOptions -> O.Parser CmdArgs +parser envOpts = 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" - ) - <*> O.optional - ( O.option O.auto - ( O.long "untabify" <> O.metavar "TABSIZE" - <> O.help "Convert tabs to the spaces at the tab stops for the given tab size" - ) - ) - <*> O.optional - ( O.strOption - ( O.long "merge-file" <> O.short 'f' <> O.help "Merge a specific file") - ) - <*> O.option O.auto - (O.long "context" <> O.short 'U' <> O.metavar "LINECOUNT" <> O.showDefault <> O.value 3 - <> O.help "Number of context lines around dumped diffs" - ) - ) + <|> CmdOptions <$> optionsParser envOpts -opts :: O.ParserInfo CmdArgs -opts = - O.info (O.helper <*> parser) $ +opts :: O.Parser EnvOptions -> O.ParserInfo CmdArgs +opts envOpts = + O.info (O.helper <*> parser envOpts) $ O.fullDesc <> O.progDesc "Resolve any git conflicts that have become trivial by editing operations.\n\ @@ -79,7 +90,8 @@ getOpts :: IO Options getOpts = - O.execParser opts + OptUtils.parseEnvOptions "GIT_MEDIATE_OPTIONS" envOptsParser + >>= O.execParser . opts >>= \case CmdVersion -> do diff --git a/src/PPDiff.hs b/src/PPDiff.hs --- a/src/PPDiff.hs +++ b/src/PPDiff.hs @@ -1,7 +1,7 @@ module PPDiff - ( ColorEnable(..) - , ppDiff - ) where + ( ColorEnable (..) + , ppDiff + ) where import Data.Algorithm.Diff (Diff, PolyDiff(..)) import System.Console.ANSI diff --git a/src/Resolution.hs b/src/Resolution.hs --- a/src/Resolution.hs +++ b/src/Resolution.hs @@ -3,20 +3,23 @@ module Resolution ( Result(..) , NewContent(..) - , Untabify(..) , resolveContent , fullySuccessful ) where import Conflict (Conflict(..), Sides(..)) import qualified Conflict +import Control.Monad (guard) import Data.Foldable (Foldable(..)) +import Data.List (isPrefixOf) +import Data.List.Split (splitWhen) import Generic.Data (Generic, Generically(..)) +import ResolutionOpts import Prelude.Compat data Resolution - = NoResolution + = NoResolution Conflict | Resolution String | PartialResolution String @@ -27,18 +30,29 @@ | a == b = Just a | otherwise = Nothing -resolveConflict :: Conflict -> Resolution -resolveConflict c = - case resolveGen c.bodies of - Just r -> Resolution $ unlines r - Nothing - | matchTop > 0 || matchBottom > 0 -> - PartialResolution $ unlines $ - take matchTop c.bodies.sideA ++ - Conflict.prettyLines (Conflict.setEachBody unmatched c) ++ - takeEnd matchBottom c.bodies.sideA - | otherwise -> NoResolution +resolveGenLines :: Eq a => ResolutionOptions -> Sides [a] -> Maybe [a] +resolveGenLines opts sides@(Sides a base b) = + case guard opts.trivial >> resolveGen sides of + Just x -> Just x + _ | opts.addedLines -> + case addedBothSides a b <> addedBothSides b a of + [x] -> Just x + _ -> Nothing + _ -> Nothing where + n = length base + addedBothSides x y = [x <> drop n y | drop (length x - n) x == base && take n y == base] + +resolveConflict :: ResolutionOptions -> Conflict -> Resolution +resolveConflict opts c + | matchTop == 0 && matchBottom == 0 || not opts.reduce = + maybe (NoResolution c) (Resolution . unlines) (resolveGenLines opts c.bodies) + | otherwise = + case resolveGenLines opts reduced.bodies of + Just x -> Resolution $ formatRes x + Nothing -> PartialResolution $ formatRes $ Conflict.prettyLines reduced + where + formatRes mid = unlines $ take matchTop c.bodies.sideA <> mid <> takeEnd matchBottom c.bodies.sideA match base a b | null base = lengthOfCommonPrefix a b | otherwise = minimum $ map (lengthOfCommonPrefix base) [a, b] @@ -48,6 +62,7 @@ dropEnd count xs = take (length xs - count) xs takeEnd count xs = drop (length xs - count) xs unmatched xs = drop matchTop $ dropEnd matchBottom xs + reduced = Conflict.setEachBody unmatched c lengthOfCommonPrefix :: Eq a => [a] -> [a] -> Int lengthOfCommonPrefix x y = length $ takeWhile id $ zipWith (==) x y @@ -73,8 +88,6 @@ deriving Generic deriving (Semigroup, Monoid) via Generically NewContent -newtype Untabify = Untabify { mUntabifySize :: Maybe Int } - untabifyStr :: Int -> String -> String untabifyStr size = go 0 @@ -86,8 +99,8 @@ go !col (x:rest) = x : go (cyclicInc col) rest go _ [] = [] -untabify :: Int -> Conflict -> Conflict -untabify = Conflict.setStrings . untabifyStr +untabifyConflict :: Int -> Conflict -> Conflict +untabifyConflict = Conflict.setStrings . untabifyStr data LineEnding = LF | CRLF | Mixed deriving (Eq, Ord) @@ -96,9 +109,9 @@ lineEnding x@(_:_) | last x == '\r' = CRLF lineEnding _ = LF -lineEndings :: [String] -> LineEnding -lineEndings [] = Mixed -lineEndings xs = +inferLineEndings :: [String] -> LineEnding +inferLineEndings [] = Mixed +inferLineEndings xs = foldl1 f (map lineEnding xs) where f Mixed _ = Mixed @@ -120,21 +133,45 @@ Just CRLF -> Conflict.setStrings makeCr c _ -> c where - endings = fmap lineEndings c.bodies + endings = fmap inferLineEndings c.bodies removeCr x@(_:_) | last x == '\r' = init x removeCr x = x makeCr x@(_:_) | last x == '\r' = x makeCr x = x <> "\r" -resolveContent :: Untabify -> [Either String Conflict] -> NewContent -resolveContent (Untabify mTabSize) = +formatResolution :: Resolution -> NewContent +formatResolution (NoResolution c) = NewContent (Result 0 0 1) (Conflict.pretty c) +formatResolution (Resolution trivialLines) = NewContent (Result 1 0 0) trivialLines +formatResolution (PartialResolution newLines) = NewContent (Result 0 1 0) newLines + +resolveContent :: ResolutionOptions -> [Either String Conflict] -> NewContent +resolveContent opts = foldMap go where - untabified = maybe id untabify mTabSize go (Left line) = NewContent mempty (unlines [line]) - go (Right conflict) = - case (resolveConflict . lineBreakFix . untabified) conflict of - NoResolution -> NewContent (Result 0 0 1) - (Conflict.pretty (untabified conflict)) - Resolution trivialLines -> NewContent (Result 1 0 0) trivialLines - PartialResolution newLines -> NewContent (Result 0 1 0) newLines + go (Right conflict) + | opts.splitMarkers = + r <> splitProgress + | otherwise = resolve conflict + where + s = splitConflict conflict + r = foldMap resolve s + splitProgress = + case s of + (_:_:_) -> NewContent (Result 0 1 0) mempty + _ -> mempty + resolve conflict = + formatResolution $ resolveConflict opts $ + (if opts.lineEndings then lineBreakFix else id) $ + maybe id untabifyConflict opts.untabify conflict + +splitConflict :: Conflict -> [Conflict] +splitConflict c = + maybe [c] ((\s -> c{bodies=s}) <$>) $ + matchSplits $ splitWhen (isPrefixOf "~~~~~~~") <$> c.bodies + +matchSplits :: Sides [a] -> Maybe [Sides a] +matchSplits (Sides (a:as) (b:bs) (c:cs)) = + (Sides a b c :) <$> matchSplits (Sides as bs cs) +matchSplits (Sides [] [] []) = Just [] +matchSplits _ = Nothing diff --git a/src/ResolutionOpts.hs b/src/ResolutionOpts.hs new file mode 100644 --- /dev/null +++ b/src/ResolutionOpts.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module ResolutionOpts + ( ResolutionOptions(..), parser, isResolving + ) where + +import Data.Maybe (isJust) +import qualified OptUtils + +data ResolutionOptions = ResolutionOpts + { trivial :: Bool + , reduce :: Bool + , untabify :: Maybe Int + , lineEndings :: Bool + , addedLines :: Bool + , splitMarkers :: Bool + } + +parser :: OptUtils.Parser ResolutionOptions +parser = + ResolutionOpts + <$> OptUtils.envSwitch "trivial" True "trivial conflicts resolution" + <*> OptUtils.envSwitch "reduce" True "conflict reduction" + <*> OptUtils.envOptional "untabify" "TABSIZE" + "Convert tabs to the spaces at the tab stops for the given tab size" + (\x -> "Disable converting tabs to " <> show x <> " spaces at the tab stops") + <*> OptUtils.envSwitch "line-endings" True "line-ending characters conflict resolution" + <*> OptUtils.envSwitch "lines-added-around" False + "resolve conflicts where one change prepended lines to the base and the other appended" + <*> OptUtils.envSwitch "split-markers" False "split conflicts at tilde-split-markers" + +isResolving :: ResolutionOptions -> Bool +isResolving o = o.trivial || o.reduce || isJust o.untabify || o.lineEndings || o.addedLines diff --git a/src/SideDiff.hs b/src/SideDiff.hs --- a/src/SideDiff.hs +++ b/src/SideDiff.hs @@ -5,10 +5,10 @@ , getConflictDiffs, getConflictDiff2s ) where -import Conflict (Conflict(..), Sides(..), SrcContent(..)) -import Data.Algorithm.Diff (Diff, getDiff) +import Conflict (Conflict(..), Sides(..), SrcContent(..)) +import Data.Algorithm.Diff (Diff, getDiff) -import Prelude.Compat +import Prelude.Compat data Side = A | B deriving (Eq, Ord, Show) diff --git a/src/StrUtils.hs b/src/StrUtils.hs --- a/src/StrUtils.hs +++ b/src/StrUtils.hs @@ -1,10 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} module StrUtils - ( stripNewline, ensureNewline, unprefix + ( (), stripNewline, ensureNewline ) where -import Data.List (isPrefixOf, isSuffixOf) +import Data.List (isSuffixOf) +import qualified System.FilePath as FilePath import Prelude.Compat @@ -21,7 +22,6 @@ | "\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 +() :: FilePath -> FilePath -> FilePath +"." p = p +d p = d FilePath. p diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ flags: {} packages: - '.' -resolver: lts-21.3 +resolver: lts-22.30