156 lines
5 KiB
Haskell
156 lines
5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Merge
|
|
( MergeOpts(..)
|
|
, mergeOption
|
|
, fmtMerged
|
|
, merge
|
|
) where
|
|
|
|
import qualified Data.ByteString.Builder as BB
|
|
import Data.String
|
|
import Options.Applicative
|
|
import Types
|
|
|
|
data MergeOpts =
|
|
MergeOpts
|
|
{ mergeDoMerge :: Bool
|
|
, mergeIgnoreWhitespace :: Bool
|
|
, mergeForceWhitespace :: Bool
|
|
, mergeKeepWhitespace :: Bool
|
|
, mergeCStartStr :: BS
|
|
, mergeMineSepStr :: BS
|
|
, mergeYourSepStr :: BS
|
|
, mergeCEndStr :: BS
|
|
}
|
|
deriving (Show)
|
|
|
|
mergeOption :: Bool -> Parser MergeOpts
|
|
mergeOption forPatch =
|
|
addLBR <$>
|
|
((,) <$>
|
|
switch
|
|
(short 'a' <>
|
|
long "add-linebreak" <>
|
|
help "Automatically add a line break after conflict markers. Useful with `lines' lexer.") <*>
|
|
mo)
|
|
where
|
|
marker = fromString . replicate 7
|
|
mo =
|
|
MergeOpts <$>
|
|
switch
|
|
(short 'm' <>
|
|
long "merge" <>
|
|
help
|
|
(if forPatch
|
|
then "Instead of printing the rejected thunks, merge using conflict markers as if the INPUT was `MYFILE' and the patch would produced `YOURFILE' from the original."
|
|
else "Output the merged file instead of the patch")) <*>
|
|
switch
|
|
(short 'I' <>
|
|
long "ignore-whitespace" <>
|
|
help
|
|
("Ignore " ++
|
|
(if forPatch
|
|
then "hunks"
|
|
else "chunks") ++
|
|
" that change only whitespace")) <*>
|
|
switch
|
|
(short 'F' <>
|
|
long "force-whitespace" <>
|
|
help
|
|
((if forPatch
|
|
then "Force rejecting a hunk"
|
|
else "Force a merge conflict") ++
|
|
" on whitespace mismatch (overrides `ignore-whitespace')")) <*>
|
|
switch
|
|
(short 'K' <>
|
|
long "keep-whitespace" <>
|
|
help
|
|
("On whitespace mismatch, output the version from " ++
|
|
(if forPatch
|
|
then "the original file"
|
|
else "MYFILE") ++
|
|
" instead of the one from " ++
|
|
(if forPatch
|
|
then "the context in patch"
|
|
else "YOURFILE"))) <*>
|
|
strOption
|
|
(long "merge-start" <>
|
|
value (marker '<') <> help "Marker for the beginning of a conflict") <*>
|
|
strOption
|
|
(long "merge-mine" <>
|
|
value (marker '|') <>
|
|
help
|
|
"Marker that separates `mine' from `original' part of the conflict") <*>
|
|
strOption
|
|
(long "merge-your" <>
|
|
value (marker '=') <>
|
|
help
|
|
"Marker that separates `original' from `your' part of the conflict") <*>
|
|
strOption
|
|
(long "merge-end" <>
|
|
value (marker '>') <> help "Marker for the end of a conflict")
|
|
addLBR (False, x) = x
|
|
addLBR (True, x) =
|
|
x
|
|
{ mergeCStartStr = mergeCStartStr x <> "\n"
|
|
, mergeMineSepStr = mergeMineSepStr x <> "\n"
|
|
, mergeYourSepStr = mergeYourSepStr x <> "\n"
|
|
, mergeCEndStr = mergeCEndStr x <> "\n"
|
|
}
|
|
|
|
{- This kinda relies on reasonable ordering
|
|
- within the conflicts in the Diff -}
|
|
fmtMerged :: MergeOpts -> Diff -> BB.Builder
|
|
fmtMerged mo = go Keep
|
|
where
|
|
go op []
|
|
| conflictOp op = bb $ mergeCEndStr mo
|
|
| otherwise = mempty
|
|
go prev l@((op, (_, tok)):xs)
|
|
| conflictOp prev && not (conflictOp op) =
|
|
bb (mergeCEndStr mo) <> go Keep l
|
|
| not (conflictOp prev) && conflictOp op =
|
|
bb (mergeCStartStr mo) <> go MineChanged l
|
|
| prev /= op && conflictOp op =
|
|
(case op of
|
|
MineChanged -> bb $ mergeCStartStr mo
|
|
Original -> bb $ mergeMineSepStr mo
|
|
YourChanged -> bb $ mergeYourSepStr mo
|
|
_ -> error "Internal conflict handling failure") <>
|
|
go op l
|
|
| op == Remove = go op xs
|
|
| otherwise = bb tok <> go op xs
|
|
conflictOp o =
|
|
case o of
|
|
Keep -> False
|
|
Add -> False
|
|
Remove -> False
|
|
_ -> True
|
|
bb = BB.byteString
|
|
|
|
merge :: MergeOpts -> [(Origin, (Op, Tok))] -> Diff
|
|
merge mo cs = go
|
|
where
|
|
mys@[diffMine, diffYour] =
|
|
map (\a -> map snd $ filter ((a ==) . fst) cs) [Mine, Your]
|
|
[tokOrigsMine, tokOrigsYour] = map (map snd . filter ((Add /=) . fst)) mys
|
|
[tokMine, tokYour] = map (map snd . filter ((Remove /=) . fst)) mys
|
|
conflict =
|
|
map (MineChanged, ) tokMine ++
|
|
map (Original, ) tokOrigsMine ++ map (YourChanged, ) tokYour
|
|
noTokens = all (not . fst . snd) (diffMine ++ diffYour)
|
|
go
|
|
| tokOrigsMine /= tokOrigsYour =
|
|
error "Internal failure: merge origins differ"
|
|
| mergeIgnoreWhitespace mo && noTokens = map (Keep, ) tokOrigsMine
|
|
| all ((Keep ==) . fst) diffYour = diffMine -- only mine changed
|
|
| all ((Keep ==) . fst) diffMine = diffYour -- only your changed
|
|
| diffMine == diffYour = diffMine -- false conflict
|
|
| not (mergeForceWhitespace mo) && noTokens =
|
|
if mergeKeepWhitespace mo
|
|
then diffMine
|
|
else diffYour -- conflict happened, but not on significant tokens
|
|
| otherwise = conflict -- true conflict
|