git-mediate 1.0.9 → 1.1.0
raw patch · 15 files changed
+586/−251 lines, 15 filesdep +containersdep +splitdep ~base
Dependencies added: containers, split
Dependency ranges changed: base
Files
- ChangeLog.md +10/−1
- README.md +7/−2
- git-mediate.cabal +7/−2
- src/Conflict.hs +32/−25
- src/Environment.hs +9/−4
- src/Git.hs +105/−0
- src/Main.hs +91/−126
- src/OptUtils.hs +152/−0
- src/Opts.hs +60/−48
- src/PPDiff.hs +3/−3
- src/Resolution.hs +67/−30
- src/ResolutionOpts.hs +33/−0
- src/SideDiff.hs +3/−3
- src/StrUtils.hs +6/−6
- stack.yaml +1/−1
ChangeLog.md view
@@ -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)
README.md view
@@ -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:
git-mediate.cabal view
@@ -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
src/Conflict.hs view
@@ -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
src/Environment.hs view
@@ -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 ()
+ src/Git.hs view
@@ -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
src/Main.hs view
@@ -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
+ src/OptUtils.hs view
@@ -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-<name> or --<name> 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-<name> 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))
src/Opts.hs view
@@ -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
src/PPDiff.hs view
@@ -1,7 +1,7 @@ module PPDiff- ( ColorEnable(..)- , ppDiff- ) where+ ( ColorEnable (..)+ , ppDiff+ ) where import Data.Algorithm.Diff (Diff, PolyDiff(..)) import System.Console.ANSI
src/Resolution.hs view
@@ -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
+ src/ResolutionOpts.hs view
@@ -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
src/SideDiff.hs view
@@ -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)
src/StrUtils.hs view
@@ -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
stack.yaml view
@@ -1,4 +1,4 @@ flags: {} packages: - '.'-resolver: lts-21.3+resolver: lts-22.30