git-mediate 1.0.1 → 1.0.2
raw patch · 8 files changed
+300/−220 lines, 8 files
Files
- Conflict.hs +98/−0
- Environment.hs +64/−0
- Opts.hs +4/−5
- Resolution.hs +46/−0
- SideDiff.hs +26/−0
- StrUtils.hs +27/−0
- git-mediate.cabal +11/−3
- git-mediate.hs +24/−212
+ Conflict.hs view
@@ -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
+ Environment.hs view
@@ -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 ()
Opts.hs view
@@ -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
+ Resolution.hs view
@@ -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
+ SideDiff.hs view
@@ -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)
+ StrUtils.hs view
@@ -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
git-mediate.cabal view
@@ -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
git-mediate.hs view
@@ -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