150 lines
3.9 KiB
Haskell
150 lines
3.9 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Exception
|
|
import Control.Monad
|
|
import Data.Bool
|
|
import Data.Foldable
|
|
import Opts
|
|
import System.Exit
|
|
import System.FilePath
|
|
import System.IO
|
|
import System.IO.Temp
|
|
import System.Process
|
|
import qualified Toks
|
|
|
|
import Debug.Trace
|
|
|
|
-- TODO: the diff w
|
|
rundiff f1 f2 out = do
|
|
st <-
|
|
withFile out WriteMode $ \oh ->
|
|
withCreateProcess
|
|
(proc
|
|
"diff" -- TODO: from WERGE_DIFF env
|
|
[ "--text"
|
|
, "--new-line-format=+%L"
|
|
, "--old-line-format=-%L"
|
|
, "--unchanged-line-format= %L"
|
|
, f1
|
|
, f2
|
|
])
|
|
{std_in = NoStream, std_out = UseHandle oh, std_err = Inherit} $ \_ _ _ ->
|
|
waitForProcess
|
|
when (st == ExitFailure 2) $ error "fatal: diff failed"
|
|
unless (st `elem` [ExitSuccess, ExitFailure 1])
|
|
$ error "diff failed for unknown reason (is GNU diffutils installed?)"
|
|
|
|
data Op
|
|
= Del
|
|
| Keep
|
|
| Add
|
|
deriving (Show, Eq)
|
|
|
|
pdiff path = map go . lines <$> readFile path
|
|
where
|
|
go [] = error "empty line from diff"
|
|
go ('-':s) = (Del, s)
|
|
go (' ':s) = (Keep, s)
|
|
go ('+':s) = (Add, s)
|
|
|
|
data Merged
|
|
= Ok [String]
|
|
| Conflict [String] [String] [String]
|
|
deriving (Show)
|
|
|
|
align :: [(Op, String)] -> [(Op, String)] -> [Merged]
|
|
align [] [] = []
|
|
align ((Keep, m):ms) ((Keep, y):ys)
|
|
| m == y = Ok [m] : align ms ys
|
|
align ((Del, m):ms) ((Del, y):ys)
|
|
| m == y = Conflict [] [m] [] : align ms ys
|
|
align ((Del, m):ms) ((Keep, y):ys)
|
|
| m == y = Conflict [] [m] [m] : align ms ys
|
|
align ((Keep, m):ms) ((Del, y):ys)
|
|
| m == y = Conflict [m] [m] [] : align ms ys
|
|
align ((Add, m):ms) ys = Conflict [m] [] [] : align ms ys
|
|
align ms ((Add, y):ys) = Conflict [] [] [y] : align ms ys
|
|
align _ _ = error "fatal: diffs do not align"
|
|
|
|
-- TODO this is quadratic, call regroup first and case it
|
|
regroup :: [Merged] -> [Merged]
|
|
regroup [] = []
|
|
regroup (Ok []:xs) = regroup xs
|
|
regroup (Ok a:Ok b:xs) = regroup (Ok (a ++ b) : xs)
|
|
regroup (Conflict [] [] []:xs) = regroup xs
|
|
regroup (Conflict m1 o1 y1:Conflict m2 o2 y2:xs) =
|
|
regroup (Conflict (m1 ++ m2) (o1 ++ o2) (y1 ++ y2) : xs)
|
|
regroup (x:xs) = x : regroup xs
|
|
|
|
expand :: Int -> [Merged] -> [Merged]
|
|
expand n = go
|
|
where
|
|
go [] = []
|
|
go (Conflict m1 o1 y1:Ok a:Conflict m2 o2 y2:xs)
|
|
| length a <= n =
|
|
go $ Conflict (m1 ++ a ++ m2) (o1 ++ a ++ o2) (y1 ++ a ++ y2) : xs
|
|
go (x:xs) = x : go xs
|
|
|
|
zeal = id -- TODO
|
|
|
|
resolve _ c@(Conflict m o y)
|
|
| m == o && o == y = Ok o
|
|
| m == o = Ok y
|
|
| o == y = Ok m
|
|
| m == y = Ok m
|
|
resolve cfg x = x
|
|
|
|
merge cfg@Config {..} ms ys =
|
|
regroup
|
|
. map (resolve cfg)
|
|
. bool id zeal cfgZealous
|
|
. expand cfgContext
|
|
. regroup
|
|
$ align ms ys
|
|
|
|
format :: Config -> [Merged] -> IO Bool
|
|
format Config {..} = go False
|
|
where
|
|
go c [] = pure c
|
|
go c (Ok x:xs) = do
|
|
putStr (Toks.glueToks x)
|
|
go c xs
|
|
go c (Conflict m o y:xs) = do
|
|
putStr
|
|
$ mconcat
|
|
[ cfgLabelStart
|
|
, Toks.glueToks m
|
|
, cfgLabelMyOld
|
|
, Toks.glueToks o
|
|
, cfgLabelOldYour
|
|
, Toks.glueToks y
|
|
, cfgLabelEnd
|
|
]
|
|
go True xs
|
|
|
|
runCmd CmdDiff3 {..} cfg =
|
|
withSystemTempDirectory "werge-diff3" $ \workdir -> do
|
|
let [fMy, fOld, fYour, fdMy, fdYour] =
|
|
map (workdir </>) ["my", "old", "your", "mydiff", "yourdiff"]
|
|
for_ [(d3my, fMy), (d3old, fOld), (d3your, fYour)] $ \(path, tmp) ->
|
|
readFile path >>= writeFile tmp . Toks.split
|
|
rundiff fOld fMy fdMy
|
|
rundiff fOld fYour fdYour
|
|
conflicted <- merge cfg <$> pdiff fdMy <*> pdiff fdYour >>= format cfg
|
|
if conflicted
|
|
then exitWith (ExitFailure 1)
|
|
else exitSuccess
|
|
runCmd _ _ = error "not implemented yet"
|
|
|
|
main :: IO ()
|
|
main = catch go bad
|
|
where
|
|
go = do
|
|
(cfg, cmd) <- parseOpts
|
|
runCmd cmd cfg
|
|
bad e = do
|
|
hPutStrLn stderr $ "fatal: " ++ displayException (e :: IOException)
|
|
exitWith (ExitFailure 2)
|