diff --git a/Conflict.hs b/Conflict.hs new file mode 100644 --- /dev/null +++ b/Conflict.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, RecordWildCards #-} + +module Conflict + ( Conflict(..), LineNo + , prettyConflict, prettyConflictLines + , parseConflicts + , markerPrefix + ) where + +import Control.Monad.State (MonadState, state, evalStateT) +import Control.Monad.Writer (runWriter, tell) +import Data.List (isPrefixOf) + +import Prelude.Compat + +type LineNo = Int + +data Conflict = Conflict + { cMarkerA :: (LineNo, String) -- <<<<<<<.... + , cMarkerBase :: (LineNo, String) -- |||||||.... + , cMarkerB :: (LineNo, String) -- =======.... + , cMarkerEnd :: (LineNo, String) -- >>>>>>>.... + , cLinesA :: [String] + , cLinesBase :: [String] + , cLinesB :: [String] + } deriving (Show) + +prettyConflictLines :: Conflict -> [String] +prettyConflictLines Conflict {..} = + concat + [ snd cMarkerA : cLinesA + , snd cMarkerBase : cLinesBase + , snd cMarkerB : cLinesB + , [snd cMarkerEnd] + ] + +prettyConflict :: Conflict -> String +prettyConflict = unlines . prettyConflictLines + +-- '>' -> ">>>>>>>" +markerPrefix :: Char -> String +markerPrefix = replicate 7 + +breakUpToMarker :: MonadState [(LineNo, String)] m => Char -> m [(LineNo, String)] +breakUpToMarker c = state (break ((markerPrefix c `isPrefixOf`) . snd)) + +readHead :: MonadState [a] m => m (Maybe a) +readHead = state f + where + f [] = (Nothing, []) + f (l:ls) = (Just l, ls) + +tryReadUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], Maybe (LineNo, String)) +tryReadUpToMarker c = + do + ls <- breakUpToMarker c + mHead <- readHead + return (ls, mHead) + +readUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], (LineNo, String)) +readUpToMarker c = do + res <- tryReadUpToMarker c + case res of + (ls, Just h) -> return (ls, h) + (ls, Nothing) -> + error $ concat + [ "Parse error: failed reading up to marker: " + , show c, ", got:" + , concatMap (\(l,s) -> "\n" ++ show l ++ "\t" ++ s) $ take 5 ls + ] + +parseConflict :: MonadState [(LineNo, String)] m => (LineNo, String) -> m Conflict +parseConflict markerA = + do (linesA , markerBase) <- readUpToMarker '|' + (linesBase, markerB) <- readUpToMarker '=' + (linesB , markerEnd) <- readUpToMarker '>' + return Conflict + { cMarkerA = markerA + , cMarkerBase = markerBase + , cMarkerB = markerB + , cMarkerEnd = markerEnd + , cLinesA = map snd linesA + , cLinesB = map snd linesB + , cLinesBase = map snd linesBase + } + +parseConflicts :: String -> [Either String Conflict] +parseConflicts input = + snd $ runWriter $ evalStateT loop (zip [1..] (lines input)) + where + loop = + do (ls, mMarkerA) <- tryReadUpToMarker '<' + tell $ map (Left . snd) ls + case mMarkerA of + Nothing -> return () + Just markerA -> + do tell . return . Right =<< parseConflict markerA + loop diff --git a/Environment.hs b/Environment.hs new file mode 100644 --- /dev/null +++ b/Environment.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Environment + ( checkConflictStyle, shouldUseColorByTerminal, openEditor + ) where + +import qualified Control.Exception as E +import Control.Monad (when, unless) +import Opts (Options(..)) +import PPDiff (ColorEnable(..)) +import StrUtils (stripNewline) +import System.Environment (getEnv) +import System.Exit (ExitCode(..)) +import System.Posix.IO (stdOutput) +import System.Posix.Terminal (queryTerminal) +import System.Process (callProcess, readProcessWithExitCode) + +import Prelude.Compat + +shouldUseColorByTerminal :: IO ColorEnable +shouldUseColorByTerminal = + do istty <- queryTerminal stdOutput + return $ if istty then EnableColor else DisableColor + +getConflictStyle :: IO String +getConflictStyle = + do (exitCode, stdout, _) <- readProcessWithExitCode "git" ["config", "merge.conflictstyle"] stdin + case exitCode of + ExitSuccess -> return $ stripNewline stdout + ExitFailure 1 -> return "unset" + ExitFailure _ -> E.throwIO exitCode + where + stdin = "" + +setConflictStyle :: IO () +setConflictStyle = + callProcess "git" ["config", "--global", "merge.conflictstyle", "diff3"] + +checkConflictStyle :: Options -> IO () +checkConflictStyle opts = + do conflictStyle <- getConflictStyle + when (conflictStyle /= "diff3") $ + do unless (shouldSetConflictStyle opts) $ + fail $ concat + [ "merge.conflictstyle must be diff3 but is " + , show conflictStyle + , ". Use -s to automatically set it globally" + ] + setConflictStyle + + newConflictStyle <- getConflictStyle + when (newConflictStyle /= "diff3") $ + fail $ concat + [ "Attempt to set conflict style failed. Perhaps you have" + , " an incorrect merge.conflictstyle configuration " + , "specified in your per-project .git/config?" + ] + +openEditor :: Options -> FilePath -> IO () +openEditor opts path + | shouldUseEditor opts = + do editor <- getEnv "EDITOR" + callProcess editor [path] + | otherwise = return () diff --git a/Opts.hs b/Opts.hs --- a/Opts.hs +++ b/Opts.hs @@ -46,10 +46,9 @@ (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.switch + ( O.long "style" <> O.short 's' + <> O.help "Configure git's global merge.conflictstyle to diff3 if needed" ) ) @@ -70,4 +69,4 @@ do putStrLn $ "git-mediate version " ++ versionString exitSuccess - CmdOptions opts -> return opts + CmdOptions o -> return o diff --git a/Resolution.hs b/Resolution.hs new file mode 100644 --- /dev/null +++ b/Resolution.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-} + +module Resolution + ( Resolution(..) + , resolveConflict + ) where + +import Conflict (Conflict(..), prettyConflictLines) + +import Prelude.Compat + +data Resolution + = NoResolution + | Resolution String + | PartialResolution String + +resolveConflict :: Conflict -> Resolution +resolveConflict conflict@Conflict{..} + | cLinesA == cLinesBase = Resolution $ unlines cLinesB + | cLinesB == cLinesBase = Resolution $ unlines cLinesA + | cLinesA == cLinesB = Resolution $ unlines cLinesA + | matchTop > 0 || matchBottom > 0 = + PartialResolution $ unlines $ + take matchTop cLinesBase ++ + prettyConflictLines conflict + { cLinesA = unmatched cLinesA + , cLinesBase = unmatched cLinesBase + , cLinesB = unmatched cLinesB + } ++ + takeEnd matchBottom cLinesBase + | otherwise = NoResolution + where + matchTop = + minimum $ map (lengthOfCommonPrefix cLinesBase) [cLinesA, cLinesB] + revBottom = reverse . drop matchTop + revBottomBase = revBottom cLinesBase + matchBottom = + minimum $ + map (lengthOfCommonPrefix revBottomBase . revBottom) + [cLinesA, cLinesB] + dropEnd count xs = take (length xs - count) xs + takeEnd count xs = drop (length xs - count) xs + unmatched xs = drop matchTop $ dropEnd matchBottom xs + +lengthOfCommonPrefix :: Eq a => [a] -> [a] -> Int +lengthOfCommonPrefix x y = length $ takeWhile id $ zipWith (==) x y diff --git a/SideDiff.hs b/SideDiff.hs new file mode 100644 --- /dev/null +++ b/SideDiff.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-} + +module SideDiff + ( SideDiff, Side(..) + , getConflictDiffs, getConflictDiff2s + ) where + +import Conflict (Conflict(..), LineNo) +import Data.Algorithm.Diff (Diff, getDiff) + +import Prelude.Compat + +data Side = A | B + deriving (Eq, Ord, Show) + +type SideDiff = (Side, (LineNo, String), [Diff String]) + +getConflictDiffs :: Conflict -> [SideDiff] +getConflictDiffs Conflict{..} = + [ (A, cMarkerA, getDiff cLinesBase cLinesA) + | not (null cLinesA) ] ++ + [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cLinesBase cLinesB) + | not (null cLinesB) ] + +getConflictDiff2s :: Conflict -> ((LineNo, String), (LineNo, String), [Diff String]) +getConflictDiff2s Conflict{..} = (cMarkerA, cMarkerB, getDiff cLinesA cLinesB) diff --git a/StrUtils.hs b/StrUtils.hs new file mode 100644 --- /dev/null +++ b/StrUtils.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module StrUtils + ( stripNewline, ensureNewline, unprefix + ) where + +import Data.List (isPrefixOf, isSuffixOf) + +import Prelude.Compat + +stripNewline :: String -> String +stripNewline x + | "\n" `isSuffixOf` x = init x + | otherwise = x + +ensureNewline :: String -> String +ensureNewline "" = "" +ensureNewline str = str ++ suffix + where + suffix + | "\n" `isSuffixOf` str = "" + | otherwise = "\n" + +unprefix :: Eq a => [a] -> [a] -> Maybe [a] +unprefix prefix str + | prefix `isPrefixOf` str = Just (drop (length prefix) str) + | otherwise = Nothing diff --git a/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.1 +version: 1.0.2 synopsis: Remove trivial conflict markers in a git repository description: Remove trivial conflict markers in a git repository homepage: https://github.com/Peaker/git-mediate @@ -22,9 +22,17 @@ executable git-mediate main-is: git-mediate.hs - other-modules: PPDiff, Opts, Version + other-modules: Conflict + , Environment + , Opts + , PPDiff + , Resolution + , SideDiff + , StrUtils + , Version + ghc-options: -O2 -Wall -- other-extensions: - build-depends: base >=4.6 && <5 + build-depends: base >=4.8 && <5 , base-compat >= 0.8.2 && < 0.10 , mtl >=2.1 , directory >=1.2 diff --git a/git-mediate.hs b/git-mediate.hs --- a/git-mediate.hs +++ b/git-mediate.hs @@ -1,158 +1,34 @@ -{-# OPTIONS -O2 -Wall #-} -{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RecordWildCards, LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude, LambdaCase #-} + module Main (main) where +import Conflict (Conflict(..), prettyConflict, parseConflicts, markerPrefix) import qualified Control.Exception as E import Control.Monad (when, unless, filterM) -import Control.Monad.State (MonadState, state, evalStateT) -import Control.Monad.Writer (runWriter, tell) -import Data.Algorithm.Diff (Diff, getDiff) import Data.Foldable (asum, traverse_) -import Data.List (isPrefixOf, isSuffixOf) +import Data.List (isPrefixOf) import Data.Maybe (mapMaybe) import qualified Data.Monoid as Monoid +import Environment (checkConflictStyle, openEditor, shouldUseColorByTerminal) import qualified Opts import Opts (Options(..)) import PPDiff (ppDiff, ColorEnable(..)) +import Resolution (Resolution(..), resolveConflict) +import SideDiff (getConflictDiffs, getConflictDiff2s) +import StrUtils (ensureNewline, stripNewline, unprefix) import System.Directory (renameFile, removeFile, getCurrentDirectory) -import System.Environment (getEnv) -import System.Exit (ExitCode(..)) +import System.Exit (ExitCode(..), exitWith) import System.FilePath ((<.>), makeRelative, joinPath, splitPath) import qualified System.FilePath as FilePath +import System.IO (hPutStr, stderr) import qualified System.Posix.Files as PosixFiles -import System.Posix.IO (stdOutput) -import System.Posix.Terminal (queryTerminal) import System.Process (callProcess, readProcess, readProcessWithExitCode) import Prelude.Compat -data Side = A | B - deriving (Eq, Ord, Show) -type LineNo = Int - -data Conflict = Conflict - { cMarkerA :: (LineNo, String) -- <<<<<<<.... - , cMarkerBase :: (LineNo, String) -- |||||||.... - , cMarkerB :: (LineNo, String) -- =======.... - , cMarkerEnd :: (LineNo, String) -- >>>>>>>.... - , cLinesA :: [String] - , cLinesBase :: [String] - , cLinesB :: [String] - } deriving (Show) - -prettyConflictLines :: Conflict -> [String] -prettyConflictLines Conflict {..} = - concat - [ snd cMarkerA : cLinesA - , snd cMarkerBase : cLinesBase - , snd cMarkerB : cLinesB - , [snd cMarkerEnd] - ] - -prettyConflict :: Conflict -> String -prettyConflict = unlines . prettyConflictLines - -lengthOfCommonPrefix :: Eq a => [a] -> [a] -> Int -lengthOfCommonPrefix x y = length $ takeWhile id $ zipWith (==) x y - -data Resolution - = NoResolution - | Resolution String - | PartialResolution String - -resolveConflict :: Conflict -> Resolution -resolveConflict conflict@Conflict{..} - | cLinesA == cLinesBase = Resolution $ unlines cLinesB - | cLinesB == cLinesBase = Resolution $ unlines cLinesA - | cLinesA == cLinesB = Resolution $ unlines cLinesA - | matchTop > 0 || matchBottom > 0 = - PartialResolution $ unlines $ - take matchTop cLinesBase ++ - prettyConflictLines conflict - { cLinesA = unmatched cLinesA - , cLinesBase = unmatched cLinesBase - , cLinesB = unmatched cLinesB - } ++ - takeEnd matchBottom cLinesBase - | otherwise = NoResolution - where - matchTop = - minimum $ map (lengthOfCommonPrefix cLinesBase) [cLinesA, cLinesB] - revBottom = reverse . drop matchTop - revBottomBase = revBottom cLinesBase - matchBottom = - minimum $ - map (lengthOfCommonPrefix revBottomBase . revBottom) - [cLinesA, cLinesB] - dropEnd count xs = take (length xs - count) xs - takeEnd count xs = drop (length xs - count) xs - unmatched xs = drop matchTop $ dropEnd matchBottom xs - --- '>' -> ">>>>>>>" -markerPrefix :: Char -> String -markerPrefix = replicate 7 - markerLine :: Char -> String -> String markerLine c str = markerPrefix c ++ " " ++ str ++ "\n" -breakUpToMarker :: MonadState [(LineNo, String)] m => Char -> m [(LineNo, String)] -breakUpToMarker c = state (break ((markerPrefix c `isPrefixOf`) . snd)) - -readHead :: MonadState [a] m => m (Maybe a) -readHead = state f - where - f [] = (Nothing, []) - f (l:ls) = (Just l, ls) - -tryReadUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], Maybe (LineNo, String)) -tryReadUpToMarker c = - do - ls <- breakUpToMarker c - mHead <- readHead - return (ls, mHead) - -readUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], (LineNo, String)) -readUpToMarker c = do - res <- tryReadUpToMarker c - case res of - (ls, Just h) -> return (ls, h) - (ls, Nothing) -> - error $ concat - [ "Parse error: failed reading up to marker: " - , show c, ", got:" - , concatMap (\(l,s) -> "\n" ++ show l ++ "\t" ++ s) $ take 5 ls - ] - -parseConflict :: MonadState [(LineNo, String)] m => (LineNo, String) -> m Conflict -parseConflict markerA = - do (linesA , markerBase) <- readUpToMarker '|' - (linesBase, markerB) <- readUpToMarker '=' - (linesB , markerEnd) <- readUpToMarker '>' - return Conflict - { cMarkerA = markerA - , cMarkerBase = markerBase - , cMarkerB = markerB - , cMarkerEnd = markerEnd - , cLinesA = map snd linesA - , cLinesB = map snd linesB - , cLinesBase = map snd linesBase - } - -parseConflicts :: String -> [Either String Conflict] -parseConflicts input = - snd $ runWriter $ evalStateT loop (zip [1..] (lines input)) - where - loop = - do (ls, mMarkerA) <- tryReadUpToMarker '<' - tell $ map (Left . snd) ls - case mMarkerA of - Nothing -> return () - Just markerA -> - do tell . return . Right =<< parseConflict markerA - loop - -type SideDiff = (Side, (LineNo, String), [Diff String]) - data NewContent = NewContent { _resolvedSuccessfully :: Int , _reducedConflicts :: Int @@ -160,16 +36,6 @@ , _newContent :: String } -getConflictDiffs :: Conflict -> [SideDiff] -getConflictDiffs Conflict{..} = - [ (A, cMarkerA, getDiff cLinesBase cLinesA) - | not (null cLinesA) ] ++ - [ (B, (fst cMarkerB, snd cMarkerEnd), getDiff cLinesBase cLinesB) - | not (null cLinesB) ] - -getConflictDiff2s :: Conflict -> ((LineNo, String), (LineNo, String), [Diff String]) -getConflictDiff2s Conflict{..} = (cMarkerA, cMarkerB, getDiff cLinesA cLinesB) - resolveContent :: [Either String Conflict] -> NewContent resolveContent = asResult . mconcat . map go @@ -192,18 +58,11 @@ gitAdd fileName = callProcess "git" ["add", "--", fileName] -openEditor :: Options -> FilePath -> IO () -openEditor opts path - | shouldUseEditor opts = - do editor <- getEnv "EDITOR" - callProcess editor [path] - | otherwise = return () - dumpDiffs :: ColorEnable -> Options -> FilePath -> [Conflict] -> IO () dumpDiffs colorEnable opts filePath conflicts = do when (shouldDumpDiffs opts) $ mapM_ dumpDiff $ concatMap getConflictDiffs conflicts - when (shouldDumpDiff2 opts) $ mapM_ dumpDiff2 $ map getConflictDiff2s conflicts + when (shouldDumpDiff2 opts) $ mapM_ (dumpDiff2 . getConflictDiff2s) conflicts where dumpDiff (side, (lineNo, marker), diff) = do putStrLn $ concat @@ -261,55 +120,6 @@ dumpAndOpenEditor colorEnable opts fileName [ conflict | Right conflict <- parseConflicts newContent ] -stripNewline :: String -> String -stripNewline x - | "\n" `isSuffixOf` x = init x - | otherwise = x - -shouldUseColorByTerminal :: IO ColorEnable -shouldUseColorByTerminal = - do istty <- queryTerminal stdOutput - return $ if istty then EnableColor else DisableColor - -unprefix :: Eq a => [a] -> [a] -> Maybe [a] -unprefix prefix str - | prefix `isPrefixOf` str = Just (drop (length prefix) str) - | otherwise = Nothing - -getConflictStyle :: IO String -getConflictStyle = - do (exitCode, stdout, _) <- readProcessWithExitCode "git" ["config", "merge.conflictstyle"] stdin - case exitCode of - ExitSuccess -> return $ stripNewline stdout - ExitFailure 1 -> return "unset" - ExitFailure _ -> E.throwIO exitCode - where - stdin = "" - -setConflictStyle :: IO () -setConflictStyle = - callProcess "git" ["config", "--global", "merge.conflictstyle", "diff3"] - -checkConflictStyle :: Options -> IO () -checkConflictStyle opts = - do conflictStyle <- getConflictStyle - when (conflictStyle /= "diff3") $ - do unless (shouldSetConflictStyle opts) $ - fail $ concat - [ "merge.conflictstyle must be diff3 but is " - , show conflictStyle - , ". Use -s to automatically set it globally" - ] - setConflictStyle - - newConflictStyle <- getConflictStyle - when (newConflictStyle /= "diff3") $ - fail $ concat - [ "Attempt to set conflict style failed. Perhaps you have" - , " an incorrect merge.conflictstyle configuration " - , "specified in your per-project .git/config?" - ] - relativePath :: FilePath -> FilePath -> FilePath relativePath base path | rel /= path = rel @@ -327,14 +137,6 @@ isDirectory :: FilePath -> IO Bool isDirectory x = PosixFiles.isDirectory <$> PosixFiles.getFileStatus x -ensureNewline :: String -> String -ensureNewline "" = "" -ensureNewline str = str ++ suffix - where - suffix - | "\n" `isSuffixOf` str = "" - | otherwise = "\n" - withAllStageFiles :: FilePath -> (FilePath -> Maybe FilePath -> Maybe FilePath -> IO b) -> IO b withAllStageFiles path action = @@ -387,6 +189,17 @@ do removeFile path callProcess "git" ["add", "-u", "--", path] +getStatusPorcelain :: IO String +getStatusPorcelain = + do (statusCode, statusPorcelain, statusStderr) <- + readProcessWithExitCode "git" ["status", "--porcelain"] "" + when (statusCode /= ExitSuccess) $ do + -- Print git's error message. Usually - + -- "fatal: Not a git repository (or any of the parent directories): .git" + hPutStr stderr statusStderr + exitWith statusCode + return statusPorcelain + main :: IO () main = do opts <- Opts.getOpts @@ -395,12 +208,11 @@ Nothing -> shouldUseColorByTerminal Just colorEnable -> return colorEnable checkConflictStyle opts - let stdin = "" - statusPorcelain <- readProcess "git" ["status", "--porcelain"] stdin + statusPorcelain <- getStatusPorcelain cwd <- getCurrentDirectory rootDir <- relativePath cwd . stripNewline <$> - readProcess "git" ["rev-parse", "--show-toplevel"] stdin + readProcess "git" ["rev-parse", "--show-toplevel"] "" let rootRelativeFiles = filterM (fmap not . isDirectory) . map (rootDir ) let firstMatchingPrefix :: [String] -> String -> Maybe String