diff --git a/resolve-trivial-conflicts.cabal b/resolve-trivial-conflicts.cabal --- a/resolve-trivial-conflicts.cabal +++ b/resolve-trivial-conflicts.cabal @@ -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 diff --git a/resolve_trivial_conflicts.hs b/resolve_trivial_conflicts.hs --- a/resolve_trivial_conflicts.hs +++ b/resolve_trivial_conflicts.hs @@ -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