resolve-trivial-conflicts 0.3.1.1 → 0.3.1.2
raw patch · 2 files changed
+162/−162 lines, 2 files
Files
- resolve-trivial-conflicts.cabal +1/−1
- resolve_trivial_conflicts.hs +161/−161
resolve-trivial-conflicts.cabal view
@@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: resolve-trivial-conflicts-version: 0.3.1.1+version: 0.3.1.2 synopsis: Remove trivial conflict markers in a git repository description: Remove trivial conflict markers in a git repository homepage: https://github.com/ElastiLotem/resolve-trivial-conflicts
resolve_trivial_conflicts.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS -O2 -Wall #-}-{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, RecordWildCards, LambdaCase #-} module Main (main) where import qualified Control.Exception as E@@ -25,38 +25,38 @@ import Prelude.Compat data Side = A | B- deriving (Eq, Ord, Show)+ 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)+ { cMarkerA :: (LineNo, String) -- <<<<<<<....+ , cMarkerBase :: (LineNo, String) -- |||||||....+ , cMarkerB :: (LineNo, String) -- =======....+ , cMarkerEnd :: (LineNo, String) -- >>>>>>>....+ , cLinesA :: [String]+ , cLinesBase :: [String]+ , cLinesB :: [String]+ } deriving (Show) prettyConflict :: Conflict -> String prettyConflict Conflict {..} =- unlines $ concat- [ snd cMarkerA : cLinesA- , snd cMarkerBase : cLinesBase- , snd cMarkerB : cLinesB- , [snd cMarkerEnd]- ]+ unlines $ concat+ [ snd cMarkerA : cLinesA+ , snd cMarkerBase : cLinesBase+ , snd cMarkerB : cLinesB+ , [snd cMarkerEnd]+ ] resolveConflict :: Conflict -> Maybe String resolveConflict Conflict{..}- | cLinesA == cLinesBase = Just $ unlines cLinesB- | cLinesB == cLinesBase = Just $ unlines cLinesA- | cLinesA == cLinesB = Just $ unlines cLinesA- | otherwise = Nothing+ | cLinesA == cLinesBase = Just $ unlines cLinesB+ | cLinesB == cLinesBase = Just $ unlines cLinesA+ | cLinesA == cLinesB = Just $ unlines cLinesA+ | otherwise = Nothing -- '>' -> ">>>>>>> " markerPrefix :: Char -> String-markerPrefix c = replicate 7 c+markerPrefix = replicate 7 markerLine :: Char -> String -> String markerLine c str = markerPrefix c ++ " " ++ str ++ "\n"@@ -66,54 +66,64 @@ readHead :: MonadState [a] m => m (Maybe a) readHead = state f- where- f [] = (Nothing, [])- f (l:ls) = (Just l, ls)+ where+ f [] = (Nothing, [])+ f (l:ls) = (Just l, ls) -readUpToMarker :: MonadState [(LineNo, String)] m => Char -> m ([(LineNo, String)], Maybe (LineNo, String))-readUpToMarker c =- do- ls <- breakUpToMarker c- mHead <- readHead- return (ls, mHead)+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 , Just markerBase) <- readUpToMarker '|'- (linesBase, Just markerB) <- readUpToMarker '='- (linesB , Just markerEnd) <- readUpToMarker '>'- return Conflict- { cMarkerA = markerA- , cMarkerBase = markerBase- , cMarkerB = markerB- , cMarkerEnd = markerEnd- , cLinesA = map snd linesA- , cLinesB = map snd linesB- , cLinesBase = map snd linesBase- }+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) <- readUpToMarker '<'- tell $ map (Left . snd) ls- case mMarkerA of- Nothing -> return ()- Just markerA ->- do- tell . return . Right =<< parseConflict markerA- loop+ 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- , _failedToResolve :: Int- , _newContent :: String- }+ { _resolvedSuccessfully :: Int+ , _failedToResolve :: Int+ , _newContent :: String+ } getConflictDiffs :: Conflict -> [SideDiff] getConflictDiffs Conflict{..} =@@ -122,96 +132,92 @@ resolveContent :: [Either String Conflict] -> NewContent resolveContent = asResult . mconcat . map go- where- asResult (Monoid.Sum successes, Monoid.Sum failures, newContent) =- NewContent- { _resolvedSuccessfully = successes- , _failedToResolve = failures- , _newContent = newContent- }- go (Left line) = (Monoid.Sum 0, Monoid.Sum 0, unlines [line])- go (Right conflict) =- case resolveConflict conflict of- Nothing -> (Monoid.Sum 0, Monoid.Sum 1, prettyConflict conflict)- Just trivialLines -> (Monoid.Sum 1, Monoid.Sum 0, trivialLines)+ where+ asResult (Monoid.Sum successes, Monoid.Sum failures, newContent) =+ NewContent+ { _resolvedSuccessfully = successes+ , _failedToResolve = failures+ , _newContent = newContent+ }+ go (Left line) = (Monoid.Sum 0, Monoid.Sum 0, unlines [line])+ go (Right conflict) =+ case resolveConflict conflict of+ Nothing -> (Monoid.Sum 0, Monoid.Sum 1, prettyConflict conflict)+ Just trivialLines -> (Monoid.Sum 1, Monoid.Sum 0, trivialLines) gitAdd :: FilePath -> IO () gitAdd fileName =- callProcess "git" ["add", "--", fileName]+ callProcess "git" ["add", "--", fileName] data Options = Options- { shouldUseEditor :: Bool- , shouldDumpDiffs :: Bool- , shouldUseColor :: Maybe ColorEnable- , shouldSetConflictStyle :: Bool- }+ { shouldUseEditor :: Bool+ , shouldDumpDiffs :: Bool+ , shouldUseColor :: Maybe ColorEnable+ , shouldSetConflictStyle :: Bool+ } instance Monoid Options where- mempty = Options False False Nothing False- Options oe0 od0 oc0 os0 `mappend` Options oe1 od1 oc1 os1 =- Options- (combineBool oe0 oe1 "-e")- (combineBool od0 od1 "-d")- (combineMaybe oc0 oc1 "-c or -C")- (os0 || os1)- where- err flag = error $ "Multiple " ++ flag ++ " flags used"- combineMaybe (Just _) (Just _) flag = err flag- combineMaybe Nothing Nothing _ = Nothing- combineMaybe (Just x) Nothing _ = Just x- combineMaybe Nothing (Just y) _ = Just y- combineBool True True flag = err flag- combineBool x y _ = x || y+ mempty = Options False False Nothing False+ Options oe0 od0 oc0 os0 `mappend` Options oe1 od1 oc1 os1 =+ Options+ (combineBool oe0 oe1 "-e")+ (combineBool od0 od1 "-d")+ (combineMaybe oc0 oc1 "-c or -C")+ (os0 || os1)+ where+ err flag = error $ "Multiple " ++ flag ++ " flags used"+ combineMaybe (Just _) (Just _) flag = err flag+ combineMaybe Nothing Nothing _ = Nothing+ combineMaybe (Just x) Nothing _ = Just x+ combineMaybe Nothing (Just y) _ = Just y+ combineBool True True flag = err flag+ combineBool x y _ = x || y getOpts :: [String] -> IO Options getOpts = fmap mconcat . mapM parseArg- where- parseArg "-e" = return mempty { shouldUseEditor = True }- parseArg "-d" = return mempty { shouldDumpDiffs = True }- parseArg "-c" = return mempty { shouldUseColor = Just EnableColor }- parseArg "-C" = return mempty { shouldUseColor = Just DisableColor }- parseArg "-s" = return mempty { shouldSetConflictStyle = True }- parseArg arg =- do prog <- getProgName- putStr $ unlines- [ "Usage: " ++ prog ++ " [-e] [-d] [-c] [-C] [-s]"- , ""- , "-e Execute $EDITOR for each conflicted file that remains conflicted"- , "-d Dump the left/right diffs from base in each conflict remaining"- , "-c Enable color"- , "-C Disable color"- , "-s Configure git's global merge.conflictstyle to diff3 if needed"- ]- fail $ "Unknown argument: " ++ show arg+ where+ parseArg "-e" = return mempty { shouldUseEditor = True }+ parseArg "-d" = return mempty { shouldDumpDiffs = True }+ parseArg "-c" = return mempty { shouldUseColor = Just EnableColor }+ parseArg "-C" = return mempty { shouldUseColor = Just DisableColor }+ parseArg "-s" = return mempty { shouldSetConflictStyle = True }+ parseArg arg =+ do prog <- getProgName+ putStr $ unlines+ [ "Usage: " ++ prog ++ " [-e] [-d] [-c] [-C] [-s]"+ , ""+ , "-e Execute $EDITOR for each conflicted file that remains conflicted"+ , "-d Dump the left/right diffs from base in each conflict remaining"+ , "-c Enable color"+ , "-C Disable color"+ , "-s Configure git's global merge.conflictstyle to diff3 if needed"+ ]+ fail $ "Unknown argument: " ++ show arg openEditor :: Options -> FilePath -> IO () openEditor opts path- | shouldUseEditor opts =- do- editor <- getEnv "EDITOR"- callProcess editor [path]- | otherwise = return ()+ | shouldUseEditor opts =+ do editor <- getEnv "EDITOR"+ callProcess editor [path]+ | otherwise = return () dumpDiffs :: ColorEnable -> Options -> FilePath -> [SideDiff] -> IO () dumpDiffs colorEnable opts filePath diffs- | shouldDumpDiffs opts = mapM_ dumpDiff diffs- | otherwise = return ()- where- dumpDiff (side, (lineNo, marker), diff) =- do- putStrLn $ concat- [filePath, ":", show lineNo, ":Diff", show side, ": ", marker]- putStr $ unlines $ map (ppDiff colorEnable) diff+ | shouldDumpDiffs opts = mapM_ dumpDiff diffs+ | otherwise = return ()+ where+ dumpDiff (side, (lineNo, marker), diff) =+ do putStrLn $ concat+ [filePath, ":", show lineNo, ":Diff", show side, ": ", marker]+ putStr $ unlines $ map (ppDiff colorEnable) diff dumpAndOpenEditor :: ColorEnable -> Options -> FilePath -> [SideDiff] -> IO () dumpAndOpenEditor colorEnable opts path diffs =- do- dumpDiffs colorEnable opts path diffs- openEditor opts path+ do dumpDiffs colorEnable opts path diffs+ openEditor opts path overwrite :: FilePath -> String -> IO () overwrite fileName newContent =- do- renameFile fileName bkup+ do renameFile fileName bkup writeFile fileName newContent removeFile bkup where@@ -219,33 +225,30 @@ resolve :: ColorEnable -> Options -> FilePath -> IO () resolve colorEnable opts fileName =- do- content <- parseConflicts <$> readFile fileName- case resolveContent content of- NewContent successes failures newContent- | successes == 0 &&- failures == 0 -> do- putStrLn $ fileName ++ ": No conflicts, git-adding"- gitAdd fileName- | successes == 0 -> do- putStrLn $ concat- [ fileName, ": Failed to resolve any of the "- , show failures, " conflicts" ]- doDump+ resolveContent . parseConflicts <$> readFile fileName+ >>= \case+ NewContent successes failures newContent+ | successes == 0 && failures == 0 ->+ do putStrLn $ fileName ++ ": No conflicts, git-adding"+ gitAdd fileName+ | successes == 0 ->+ do putStrLn $ concat+ [ fileName, ": Failed to resolve any of the "+ , show failures, " conflicts" ]+ doDump | otherwise ->- do- putStrLn $ concat- [ fileName, ": Successfully resolved ", show successes- , " conflicts (failed to resolve " ++ show failures ++ " conflicts)"- , if failures == 0 then ", git adding" else ""- ]- overwrite fileName newContent- if failures == 0- then gitAdd fileName- else doDump+ do putStrLn $ concat+ [ fileName, ": Successfully resolved ", show successes+ , " conflicts (failed to resolve " ++ show failures ++ " conflicts)"+ , if failures == 0 then ", git adding" else ""+ ]+ overwrite fileName newContent+ if failures == 0+ then gitAdd fileName+ else doDump where- doDump =- dumpAndOpenEditor colorEnable opts fileName+ doDump =+ dumpAndOpenEditor colorEnable opts fileName [ cDiff | Right conflict <- parseConflicts newContent , cDiff <- getConflictDiffs conflict@@ -328,8 +331,7 @@ withAllStageFiles :: FilePath -> (FilePath -> Maybe FilePath -> Maybe FilePath -> IO b) -> IO b withAllStageFiles path action =- do- let stdin = ""+ do let stdin = "" [baseTmp, localTmp, remoteTmp] <- take 3 . words <$> readProcess "git" ["checkout-index", "--stage=all", "--", path] stdin@@ -339,16 +341,14 @@ mRemoteTmp = maybePath remoteTmp action baseTmp mLocalTmp mRemoteTmp `E.finally`- do- removeFile baseTmp+ 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 <- maybe (return "") readFile mLocalTmp remoteContent <- maybe (return "") readFile mRemoteTmp overwrite path $@@ -364,8 +364,8 @@ deleteModifyConflictHandle :: FilePath -> IO () deleteModifyConflictHandle path =- do notMarked <- null . filter (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path- when notMarked $+ do marked <- any (markerPrefix '<' `isPrefixOf`) . lines <$> readFile path+ unless marked $ do putStrLn $ show path ++ " has a delete/modify conflict. Adding conflict markers" deleteModifyConflictAddMarkers path