git-mediate 1.0.5 → 1.0.6
raw patch · 9 files changed
+237/−131 lines, 9 filessetup-changed
Files
- ChangeLog.md +7/−0
- Setup.hs +0/−2
- git-mediate.cabal +2/−1
- src/Conflict.hs +40/−22
- src/Main.hs +92/−80
- src/Opts.hs +14/−0
- src/Resolution.hs +76/−20
- src/SideDiff.hs +5/−5
- stack.yaml +1/−1
+ ChangeLog.md view
@@ -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`
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
git-mediate.cabal view
@@ -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
src/Conflict.hs view
@@ -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))
src/Main.hs view
@@ -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
src/Opts.hs view
@@ -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 ) )
src/Resolution.hs view
@@ -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
src/SideDiff.hs view
@@ -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)
stack.yaml view
@@ -2,4 +2,4 @@ packages: - '.' extra-deps: []-resolver: lts-12.2+resolver: lts-14.6