diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Since 1.0.5 + +* Allow merging a specific file + +* Reduce add/add conflicts with matching prefix/suffix lines + +* Add support for `--untabify` diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain 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.5 +version: 1.0.6 synopsis: Tool to help resolving git conflicts description: Git conflict resolution has never been easier . @@ -51,6 +51,7 @@ category: Development build-type: Simple extra-source-files: stack.yaml + ChangeLog.md cabal-version: >=1.10 source-repository head diff --git a/src/Conflict.hs b/src/Conflict.hs --- a/src/Conflict.hs +++ b/src/Conflict.hs @@ -2,16 +2,18 @@ module Conflict ( Conflict(..), LineNo - , prettyConflict, prettyConflictLines - , parseConflicts + , bodyStrings, setBodyStrings + , pretty, prettyLines + , parse , markerPrefix ) where -import Control.Monad.State (MonadState, state, evalStateT) -import Control.Monad.Writer (runWriter, tell) -import Data.List (isPrefixOf) +import Control.Monad.State (MonadState, state, evalStateT) +import Control.Monad.Writer (runWriter, tell) +import Data.Functor.Identity (Identity(..)) +import Data.List (isPrefixOf) -import Prelude.Compat +import Prelude.Compat type LineNo = Int @@ -20,22 +22,34 @@ , cMarkerBase :: (LineNo, String) -- |||||||.... , cMarkerB :: (LineNo, String) -- =======.... , cMarkerEnd :: (LineNo, String) -- >>>>>>>.... - , cLinesA :: [String] - , cLinesBase :: [String] - , cLinesB :: [String] + , cBodyA :: [String] + , cBodyBase :: [String] + , cBodyB :: [String] } deriving (Show) -prettyConflictLines :: Conflict -> [String] -prettyConflictLines Conflict {..} = +-- traversal +bodyStrings :: Applicative f => (String -> f String) -> Conflict -> f Conflict +bodyStrings f c@Conflict{..} = + mk <$> traverse f cBodyA <*> traverse f cBodyBase <*> traverse f cBodyB + where + mk bodyA bodyBase bodyB = + c{cBodyA=bodyA, cBodyBase=bodyBase, cBodyB=bodyB} + +-- setter: +setBodyStrings :: (String -> String) -> Conflict -> Conflict +setBodyStrings f = runIdentity . bodyStrings (Identity . f) + +prettyLines :: Conflict -> [String] +prettyLines Conflict {..} = concat - [ snd cMarkerA : cLinesA - , snd cMarkerBase : cLinesBase - , snd cMarkerB : cLinesB + [ snd cMarkerA : cBodyA + , snd cMarkerBase : cBodyBase + , snd cMarkerB : cBodyB , [snd cMarkerEnd] ] -prettyConflict :: Conflict -> String -prettyConflict = unlines . prettyConflictLines +pretty :: Conflict -> String +pretty = unlines . prettyLines -- '>' -> ">>>>>>>" markerPrefix :: Char -> String @@ -79,14 +93,14 @@ , cMarkerBase = markerBase , cMarkerB = markerB , cMarkerEnd = markerEnd - , cLinesA = map snd linesA - , cLinesB = map snd linesB - , cLinesBase = map snd linesBase + , cBodyA = map snd linesA + , cBodyB = map snd linesB + , cBodyBase = map snd linesBase } -parseConflicts :: String -> [Either String Conflict] -parseConflicts input = - snd $ runWriter $ evalStateT loop (zip [1..] (lines input)) +parseFromNumberedLines :: [(LineNo, String)] -> [Either String Conflict] +parseFromNumberedLines = + snd . runWriter . evalStateT loop where loop = do (ls, mMarkerA) <- tryReadUpToMarker '<' @@ -96,3 +110,7 @@ Just markerA -> do tell . return . Right =<< parseConflict markerA loop + +parse :: String -> [Either String Conflict] +parse input = + parseFromNumberedLines (zip [1..] (lines input)) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,18 +2,19 @@ module Main (main) where -import Conflict (Conflict(..), prettyConflict, parseConflicts, markerPrefix) +import Conflict (Conflict(..)) +import qualified Conflict as Conflict 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 Resolution (Result(..), NewContent(..), Untabify(..)) +import qualified Resolution as Resolution import SideDiff (getConflictDiffs, getConflictDiff2s) import StrUtils (ensureNewline, stripNewline, unprefix) import System.Directory (renameFile, removeFile, getCurrentDirectory) @@ -27,32 +28,7 @@ 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) +markerLine c str = Conflict.markerPrefix c ++ " " ++ str ++ "\n" gitAdd :: FilePath -> IO () gitAdd fileName = @@ -62,7 +38,7 @@ dumpDiffs colorEnable opts filePath count (idx, conflict) = do putStrLn $ unwords ["### Conflict", show idx, "of", show count] - when (shouldDumpDiffs opts) $ mapM_ dumpDiff $ getConflictDiffs conflict + when (shouldDumpDiffs opts) $ traverse_ dumpDiff $ getConflictDiffs conflict when (shouldDumpDiff2 opts) $ dumpDiff2 $ getConflictDiff2s conflict where dumpDiff (side, (lineNo, marker), diff) = @@ -77,7 +53,7 @@ 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) + traverse_ (dumpDiffs colorEnable opts path (length conflicts)) (zip [1..] conflicts) openEditor opts path overwrite :: FilePath -> String -> IO () @@ -88,39 +64,50 @@ where bkup = fileName <.> "bk" -resolve :: ColorEnable -> Options -> FilePath -> IO () +handleFileResult :: ColorEnable -> Options -> FilePath -> NewContent -> IO () +handleFileResult colorEnable opts fileName (NewContent result 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 = Resolution.fullySuccessful result + doDump = + dumpAndOpenEditor colorEnable opts fileName + [ conflict | Right conflict <- Conflict.parse newContent ] + Result + { _resolvedSuccessfully = successes + , _reducedConflicts = reductions + , _failedToResolve = failures + } = result + +resolve :: ColorEnable -> Options -> FilePath -> IO Result 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 ] + do + resolutions <- + Resolution.resolveContent (Untabify (Opts.untabify opts)) + . Conflict.parse + <$> readFile fileName + _result resolutions <$ handleFileResult colorEnable opts fileName resolutions relativePath :: FilePath -> FilePath -> FilePath relativePath base path @@ -179,7 +166,8 @@ deleteModifyConflictHandle :: FilePath -> IO () deleteModifyConflictHandle path = - do marked <- any (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path + do marked <- + any (Conflict.markerPrefix '<' `isPrefixOf`) . lines <$> readFile path unless marked $ do putStrLn $ show path ++ " has a delete/modify conflict. Adding conflict markers" deleteModifyConflictAddMarkers path @@ -202,19 +190,16 @@ 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 <$> +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 firstMatchingPrefix :: [String] -> String -> Maybe String @@ -224,7 +209,12 @@ filesMatchingPrefixes prefixes = rootRelativeFiles . mapMaybe (firstMatchingPrefix prefixes) $ lines statusPorcelain + pure filesMatchingPrefixes +mediateAll :: ColorEnable -> Options -> IO Result +mediateAll colorEnable opts = + do filesMatchingPrefixes <- 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), @@ -232,11 +222,33 @@ deleteModifyConflicts <- filesMatchingPrefixes ["DU ", "UD "] - mapM_ deleteModifyConflictHandle deleteModifyConflicts + traverse_ deleteModifyConflictHandle deleteModifyConflicts - filesMatchingPrefixes ["UU ", "AA ", "DA ", "AD ", "DU ", "UD "] - >>= mapM_ (resolve colorEnable opts) + result <- filesMatchingPrefixes ["UU ", "AA ", "DA ", "AD ", "DU ", "UD "] + >>= foldMap (resolve colorEnable opts) -- Heuristically delete files that were remove/modify conflict -- and ended up with empty content - mapM_ removeFileIfEmpty deleteModifyConflicts + traverse_ removeFileIfEmpty deleteModifyConflicts + pure result + +exitCodeOf :: Result -> ExitCode +exitCodeOf result + | Resolution.fullySuccessful result = ExitSuccess + | otherwise = ExitFailure 111 + +exitProcess :: Result -> IO () +exitProcess = exitWith . exitCodeOf + +main :: IO () +main = + do opts <- Opts.getOpts + colorEnable <- + case shouldUseColor opts of + Nothing -> shouldUseColorByTerminal + Just colorEnable -> return colorEnable + checkConflictStyle opts + case mergeSpecificFile opts of + Nothing -> mediateAll colorEnable opts + Just path -> resolve colorEnable opts path + >>= exitProcess diff --git a/src/Opts.hs b/src/Opts.hs --- a/src/Opts.hs +++ b/src/Opts.hs @@ -19,6 +19,8 @@ , shouldDumpDiff2 :: Bool , shouldUseColor :: Maybe ColorEnable , shouldSetConflictStyle :: Bool + , untabify :: Maybe Int + , mergeSpecificFile :: Maybe FilePath } data CmdArgs = CmdVersion | CmdOptions Options @@ -49,6 +51,18 @@ <*> 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" + ) + ) + <*> ( ( Just <$> + O.strOption + (O.long "merge-file" <> O.short 'f' <> O.help "Merge a specific file") + ) + <|> pure Nothing ) ) diff --git a/src/Resolution.hs b/src/Resolution.hs --- a/src/Resolution.hs +++ b/src/Resolution.hs @@ -1,11 +1,16 @@ -{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude, RecordWildCards, BangPatterns #-} module Resolution - ( Resolution(..) - , resolveConflict + ( Result(..) + , NewContent(..) + , Untabify(..) + , resolveContent + , fullySuccessful ) where -import Conflict (Conflict(..), prettyConflictLines) +import Conflict (Conflict(..)) +import qualified Conflict as Conflict +import qualified Data.Monoid as Monoid import Prelude.Compat @@ -16,31 +21,82 @@ resolveConflict :: Conflict -> Resolution resolveConflict conflict@Conflict{..} - | cLinesA == cLinesBase = Resolution $ unlines cLinesB - | cLinesB == cLinesBase = Resolution $ unlines cLinesA - | cLinesA == cLinesB = Resolution $ unlines cLinesA + | cBodyA == cBodyBase = Resolution $ unlines cBodyB + | cBodyB == cBodyBase = Resolution $ unlines cBodyA + | cBodyA == cBodyB = Resolution $ unlines cBodyA | matchTop > 0 || matchBottom > 0 = PartialResolution $ unlines $ - take matchTop cLinesBase ++ - prettyConflictLines conflict - { cLinesA = unmatched cLinesA - , cLinesBase = unmatched cLinesBase - , cLinesB = unmatched cLinesB + take matchTop cBodyA ++ + Conflict.prettyLines conflict + { cBodyA = unmatched cBodyA + , cBodyBase = unmatched cBodyBase + , cBodyB = unmatched cBodyB } ++ - takeEnd matchBottom cLinesBase + takeEnd matchBottom cBodyA | otherwise = NoResolution where - matchTop = - minimum $ map (lengthOfCommonPrefix cLinesBase) [cLinesA, cLinesB] + match base a b + | null base = lengthOfCommonPrefix a b + | otherwise = minimum $ map (lengthOfCommonPrefix base) [a, b] + matchTop = match cBodyBase cBodyA cBodyB revBottom = reverse . drop matchTop - revBottomBase = revBottom cLinesBase - matchBottom = - minimum $ - map (lengthOfCommonPrefix revBottomBase . revBottom) - [cLinesA, cLinesB] + matchBottom = match (revBottom cBodyBase) (revBottom cBodyA) (revBottom cBodyB) 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 + +data Result = Result + { _resolvedSuccessfully :: !Int + , _reducedConflicts :: !Int + , _failedToResolve :: !Int + } + +fullySuccessful :: Result -> Bool +fullySuccessful (Result _ reduced failed) = reduced == 0 && failed == 0 + +instance Semigroup Result where + Result x0 y0 z0 <> Result x1 y1 z1 = Result (x0+x1) (y0+y1) (z0+z1) + +instance Monoid Result where mempty = Result 0 0 0 + +data NewContent = NewContent + { _result :: !Result + , _newContent :: !String + } + +instance Semigroup NewContent where + NewContent x0 y0 <> NewContent x1 y1 = NewContent (x0<>x1) (y0<>y1) + +instance Monoid NewContent where mempty = NewContent mempty mempty + +newtype Untabify = Untabify { mUntabifySize :: Maybe Int } + +untabifyStr :: Int -> String -> String +untabifyStr size = + go 0 + where + cyclicInc col + | col >= size - 1 = 0 + | otherwise = col + 1 + go !col ('\t':rest) = replicate (size - col) ' ' ++ go 0 rest + go !col (x:rest) = x : go (cyclicInc col) rest + go _ [] = [] + +untabify :: Int -> Conflict -> Conflict +untabify = Conflict.setBodyStrings . untabifyStr + +resolveContent :: Untabify -> [Either String Conflict] -> NewContent +resolveContent (Untabify mUntabifySize) = + foldMap go + where + untabified = maybe id untabify mUntabifySize + go (Left line) = NewContent mempty (unlines [line]) + go (Right conflict) = + case resolveConflict (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 diff --git a/src/SideDiff.hs b/src/SideDiff.hs --- a/src/SideDiff.hs +++ b/src/SideDiff.hs @@ -17,10 +17,10 @@ getConflictDiffs :: Conflict -> [SideDiff] getConflictDiffs Conflict{..} = - [ (A, cMarkerA, getDiff cLinesBase cLinesA) - | not (null cLinesA) ] ++ - [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cLinesBase cLinesB) - | not (null cLinesB) ] + [ (A, cMarkerA, getDiff cBodyBase cBodyA) + | not (null cBodyA) ] ++ + [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cBodyBase cBodyB) + | not (null cBodyB) ] getConflictDiff2s :: Conflict -> ((LineNo, String), (LineNo, String), [Diff String]) -getConflictDiff2s Conflict{..} = (cMarkerA, cMarkerB, getDiff cLinesA cLinesB) +getConflictDiff2s Conflict{..} = (cMarkerA, cMarkerB, getDiff cBodyA cBodyB) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -2,4 +2,4 @@ packages: - '.' extra-deps: [] -resolver: lts-12.2 +resolver: lts-14.6