From 49fcd0ca44bc3dd49019386543e32e2189d39c7f Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Thu, 17 Jul 2025 20:44:40 +0200 Subject: [PATCH] clean up --- Main.hs | 152 ++++++++++------------------------------------------ Opts.hs | 11 +++- Progs.hs | 131 ++++++++++++++++++++++++++++++++++++++++++++ Toks.hs | 6 +-- werge.cabal | 3 +- 5 files changed, 173 insertions(+), 130 deletions(-) create mode 100644 Progs.hs diff --git a/Main.hs b/Main.hs index c3e18c9..b8e2ce4 100644 --- a/Main.hs +++ b/Main.hs @@ -8,125 +8,17 @@ import Data.Bool import Data.Foldable import Data.Function import Data.List -import Data.Maybe import Data.Traversable -import Opts -import System.Environment import System.Exit import System.FilePath import System.IO import System.IO.Temp -import System.Process +import Opts +import Progs import qualified Toks import Toks (Tok) -import Debug.Trace - -{- - - interface to other programs - -} -diffProg = fromMaybe "diff" <$> lookupEnv "WERGE_DIFF" - -gitProg = fromMaybe "git" <$> lookupEnv "WERGE_GIT" - -bracketFile path mode = bracket (openFile path mode) hClose - -rundiff f1 f2 out = do - diff <- diffProg - st <- - bracketFile out WriteMode $ \oh -> - withCreateProcess - (proc - diff - [ "--text" - , "--new-line-format=+%L" - , "--old-line-format=-%L" - , "--unchanged-line-format= %L" - , f1 - , f2 - ]) - {std_in = NoStream, std_out = UseHandle oh} $ \_ _ _ -> waitForProcess - when (st == ExitFailure 2) $ error "diff failed" - unless (st `elem` [ExitSuccess, ExitFailure 1]) - $ error "diff failed for unknown reason (is GNU diffutils installed?)" - -gitRepoRelRoot = do - git <- gitProg - (path, st) <- - withCreateProcess - (proc git ["rev-parse", "--show-cdup"]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) $ error "git failed" - let [p] = lines path - pure p - -gitUnmerged = do - git <- gitProg - (paths, st) <- - withCreateProcess - (proc git ["status", "--porcelain=v1"]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) - <$> (map (drop 3) . filter ("UU " `isPrefixOf`) . lines - <$> hGetContents' oh) - <*> waitForProcess p - unless (st == ExitSuccess) $ error "git failed" - pure paths - -gitCheckoutMOY cfg u my old your = do - git <- gitProg - (paths, st) <- - withCreateProcess - (proc git ["ls-files", "--unmerged", "--", u]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) - <$> (sortOn snd - . map ((\[a, b] -> (a, b)) . take 2 . drop 1 . words) - . lines - <$> hGetContents' oh) - <*> waitForProcess p - unless (st == ExitSuccess) $ error "git failed" - let co (hash, _) path = do - st <- - withCreateProcess - (proc "git" ["cat-file", "blob", hash]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just ho) _ p -> do - hSplitToFile cfg ho path - waitForProcess p - unless (st == ExitSuccess) . error - $ "failed checking out " ++ u ++ " from blob " ++ hash - case paths of - [(_, "1"), (_, "2"), (_, "3")] -> - zipWithM co paths [old, my, your] >> pure () - _ -> error $ "bad data from ls-files for unmerged " ++ u - -gitAdd path = do - git <- gitProg - st <- rawSystem git ["add", "--", path] - unless (st == ExitSuccess) $ error "git-add failed" - -{- - - configurable splitting - - - - TODO this should probably enforce joinSpaces? - - or have joinSpaces as configurable? (probably best, default true) - -} -hSplitToFile cfg h path = - case cfgTokenizer cfg of - TokenizeCharCategory -> internal Toks.splitCategory - TokenizeCharCategorySimple -> internal Toks.splitSimple - TokenizeFilter cmd -> do - st <- - bracketFile path WriteMode $ \ho -> - withCreateProcess - (shell cmd) {std_in = UseHandle h, std_out = UseHandle ho} $ \_ _ _ -> - waitForProcess - unless (st == ExitSuccess) $ error "tokenize filter failed" - where - internal s = hGetContents h >>= writeFile path . Toks.toFile . s - {- - merge algorithms -} @@ -142,7 +34,7 @@ pdiff path = map go . lines <$> readFile path go ('-':s) = (Del, s) go (' ':s) = (Keep, s) go ('+':s) = (Add, s) - go [] = error "unexpected output from diff" + go _ = error "unexpected output from diff" data Merged = Ok [String] @@ -150,9 +42,11 @@ data Merged | Conflict [String] [String] [String] deriving (Show) +isKeepTok :: (Op, String) -> Bool isKeepTok (Keep, _) = True isKeepTok _ = False +isDelTok :: (Op, String) -> Bool isDelTok (Del, _) = True isDelTok _ = False @@ -170,6 +64,7 @@ chunks xs = let (reps, ys) = break isKeepTok xs in uncurry (Replace `on` map snd) (partition isDelTok reps) : chunks ys +align1 :: Eq a => [a] -> [a] -> ([a], [a], [a]) align1 as [] = ([], as, []) align1 [] bs = ([], [], bs) align1 (a:as) (b:bs) @@ -178,7 +73,7 @@ align1 (a:as) (b:bs) align1 _ _ = error "chunks do not align" align :: [Merged] -> [Merged] -> [Merged] -align m y = connect $ slice m y +align m0 y0 = connect $ slice m0 y0 where erase x = Replace x [] nemap _ [] = [] @@ -204,13 +99,14 @@ align m y = connect $ slice m y slice _ _ = error "unacceptable chunks" coFlag (Ok _) = False coFlag (Replace _ _) = True + coFlag _ = error "flagging unacceptable chunks" coSig (a, b) = (coFlag a, coFlag b) coConn' (a, b) (a', b') = (a && a') || (b && b') coConn = coConn' `on` coSig coGroup [] = [] coGroup (x:xs) = case coGroup xs of - xs'@(ys@(y:_):yss) + (ys@(y:_):yss) | coConn x y -> (x : ys) : yss xs' -> [x] : xs' connect = map confl . coGroup @@ -218,12 +114,14 @@ align m y = connect $ slice m y toCon (Ok o, Replace _ y) = Conflict o o y toCon (Replace o m, Ok _) = Conflict m o o toCon (Replace o m, Replace _ y) = Conflict m o y - confl = foldr cappend (Ok []) . map toCon - cappend (Ok x) (Ok o) = Ok (x ++ o) - cappend (Ok x) (Conflict m o y) = error "align consistency check fail" -- Conflict (x++m) (x++o) (x++y) - cappend (Conflict m o y) (Ok x) = Conflict (m ++ x) (o ++ x) (y ++ x) - cappend (Conflict m o y) (Conflict m' o' y') = + toCon _ = error "converting unacceptable chunks" + confl = foldr coAppend (Ok []) . map toCon + coAppend (Ok x) (Ok o) = Ok (x ++ o) + coAppend (Ok _) (Conflict _ _ _) = error "align consistency check fail" -- Conflict (x++m) (x++o) (x++y) + coAppend (Conflict m o y) (Ok x) = Conflict (m ++ x) (o ++ x) (y ++ x) + coAppend (Conflict m o y) (Conflict m' o' y') = Conflict (m ++ m') (o ++ o') (y ++ y') + coAppend _ _ = error "appending unacceptable chunks" regroup :: [Merged] -> [Merged] regroup [] = [] @@ -234,10 +132,11 @@ regroup (x@(Ok a):xs) = xs' -> x : xs' regroup (x:xs) = x : regroup xs -zeal Config {..} (Conflict m o y) = - before' ++ (Conflict (reverse m'') o (reverse y'') : after') +zeal :: Config -> Merged -> [Merged] +zeal Config {..} (Conflict m0 o0 y0) = + before' ++ (Conflict (reverse m'') o0 (reverse y'') : after') where - ((m', y'), before) = pops m y + ((m', y'), before) = pops m0 y0 ((m'', y''), rafter) = pops (reverse m') (reverse y') before' = case before of @@ -258,6 +157,7 @@ zeal Config {..} (Conflict m o y) = pops ms ys = ((ms, ys), []) zeal _ x = [x] +resolveSpace :: Config -> Merged -> Merged resolveSpace Config {..} c@(Conflict m o y) | not (all Toks.space $ concat [m, o, y]) = c | m == o && o == y = Ok o @@ -290,6 +190,7 @@ expand n = go xs' -> x : xs' go (x:xs) = x : go xs +resolve :: Config -> Merged -> Merged resolve cfg@Config {..} c@(Conflict m o y) | cfgSpaceResolution /= SpaceNormal , all Toks.space (concat [m, o, y]) = resolveSpace cfg c @@ -305,6 +206,7 @@ resolve cfg@Config {..} c@(Conflict m o y) ResolveKeep -> c resolve _ x = x +merge :: Config -> [(Op, String)] -> [(Op, String)] -> [Merged] merge cfg@Config {..} ms ys = regroup . map (resolve cfg) @@ -325,7 +227,7 @@ format Config {..} h = go False go c (Ok x:xs) = do hPutStr h (Toks.glue x) go c xs - go c (Conflict m o y:xs) = do + go _ (Conflict m o y:xs) = do hPutStr h $ mconcat [ cfgLabelStart @@ -337,7 +239,9 @@ format Config {..} h = go False , cfgLabelEnd ] go True xs + go _ _ = error "bad format (replace)" +runCmd :: Command -> Config -> IO () runCmd CmdDiff3 {..} cfg = withSystemTempDirectory "werge-diff3" $ \workdir -> do let [fMy, fOld, fYour, fdMy, fdYour] = @@ -378,9 +282,7 @@ runCmd CmdGitMerge {..} cfg = do main :: IO () main = catch go bad where - go = do - (cfg, cmd) <- parseOpts - runCmd cmd cfg + go = parseOpts >>= uncurry (flip runCmd) bad e = do hPutStrLn stderr $ "fatal: " ++ displayException (e :: IOException) exitWith (ExitFailure 2) diff --git a/Opts.hs b/Opts.hs index 7358951..dc6987f 100644 --- a/Opts.hs +++ b/Opts.hs @@ -16,6 +16,7 @@ data Tokenizer | TokenizeCharCategorySimple deriving (Show) +tokenizer :: Parser Tokenizer tokenizer = asum [ TokenizeFilter @@ -44,6 +45,7 @@ data ConflictMask = ConflictMask , cmResolveSeparate :: Bool } deriving (Show) +conflictMask :: String -> String -> Parser ConflictMask conflictMask label objs = do cmResolveOverlaps' <- fmap not . switch @@ -70,6 +72,7 @@ data Resolution | ResolveYour deriving (Show, Eq) +resolutionMode :: String -> Either String Resolution resolutionMode x | x `isPrefixOf` "keep" = Right ResolveKeep | x `isPrefixOf` "my" = Right ResolveMy @@ -86,6 +89,7 @@ data SpaceResolution | SpaceSpecial Resolution deriving (Show, Eq) +spaceMode :: String -> Either String SpaceResolution spaceMode x | x `isPrefixOf` "normal" = Right SpaceNormal | Right y <- resolutionMode x = Right (SpaceSpecial y) @@ -110,6 +114,7 @@ data Config = Config , cfgLabelEnd :: String } deriving (Show) +config :: Parser Config config = do cfgTokenizer <- tokenizer cfgZealous <- @@ -212,6 +217,7 @@ data Command } deriving (Show) +cmdDiff3 :: Parser Command cmdDiff3 = do d3my <- strArgument $ metavar "MYFILE" <> help "Version with local edits" d3old <- strArgument $ metavar "OLDFILE" <> help "Original file version" @@ -219,13 +225,15 @@ cmdDiff3 = do strArgument $ metavar "YOURFILE" <> help "Version with other people's edits" pure CmdDiff3 {..} +cmdGitMerge :: Parser Command cmdGitMerge = do gmFiles <- asum [ fmap Just . some $ strArgument $ metavar "UNMERGED" - <> help "Unmerged file tracked by git (can be specified repeatedly)" + <> help + "Unmerged file tracked by git (can be specified repeatedly)" , flag' Nothing (long "unmerged" @@ -246,6 +254,7 @@ cmdGitMerge = do -- TODO have some option to output the (partially merged) my/old/your files so -- that folks can continue with external program or so (such as meld) +cmd :: Parser Command cmd = hsubparser $ mconcat diff --git a/Progs.hs b/Progs.hs new file mode 100644 index 0000000..bb20726 --- /dev/null +++ b/Progs.hs @@ -0,0 +1,131 @@ +module Progs where + +import Control.Exception +import Control.Monad +import Data.List +import Data.Maybe +import System.Environment +import System.Exit +import System.IO +import System.Process + +import Opts +import qualified Toks + +bracketFile :: FilePath -> IOMode -> (Handle -> IO c) -> IO c +bracketFile path mode = bracket (openFile path mode) hClose + +{- + - interface to gnu diff + -} +diffProg :: IO String +diffProg = fromMaybe "diff" <$> lookupEnv "WERGE_DIFF" + +rundiff :: FilePath -> FilePath -> FilePath -> IO () +rundiff f1 f2 out = do + diff <- diffProg + st <- + bracketFile out WriteMode $ \oh -> + withCreateProcess + (proc + diff + [ "--text" + , "--new-line-format=+%L" + , "--old-line-format=-%L" + , "--unchanged-line-format= %L" + , f1 + , f2 + ]) + {std_in = NoStream, std_out = UseHandle oh} $ \_ _ _ -> waitForProcess + when (st == ExitFailure 2) $ error "diff failed" + unless (st `elem` [ExitSuccess, ExitFailure 1]) + $ error "diff failed for unknown reason (is GNU diffutils installed?)" + +{- + - interface to git + -} +gitProg :: IO String +gitProg = fromMaybe "git" <$> lookupEnv "WERGE_GIT" + +gitRepoRelRoot :: IO FilePath +gitRepoRelRoot = do + git <- gitProg + (path, st) <- + withCreateProcess + (proc git ["rev-parse", "--show-cdup"]) + {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> + (,) <$> hGetContents' oh <*> waitForProcess p + unless (st == ExitSuccess) $ error "git failed" + case lines path of + [p] -> pure p + _ -> fail "bad git-rev-parse output" + +gitUnmerged :: IO [FilePath] +gitUnmerged = do + git <- gitProg + (paths, st) <- + withCreateProcess + (proc git ["status", "--porcelain=v1"]) + {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> + (,) + <$> (map (drop 3) . filter ("UU " `isPrefixOf`) . lines + <$> hGetContents' oh) + <*> waitForProcess p + unless (st == ExitSuccess) $ error "git failed" + pure paths + +gitCheckoutMOY :: + Config -> FilePath -> FilePath -> FilePath -> FilePath -> IO () +gitCheckoutMOY cfg u my old your = do + git <- gitProg + (paths, st) <- + withCreateProcess + (proc git ["ls-files", "--unmerged", "--", u]) + {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> + (,) + <$> (sortOn snd + . map ((\[a, b] -> (a, b)) . take 2 . drop 1 . words) + . lines + <$> hGetContents' oh) + <*> waitForProcess p + unless (st == ExitSuccess) $ error "git failed" + let co (hash, _) path = do + st' <- + withCreateProcess + (proc "git" ["cat-file", "blob", hash]) + {std_in = NoStream, std_out = CreatePipe} $ \_ (Just ho) _ p -> do + hSplitToFile cfg ho path + waitForProcess p + unless (st' == ExitSuccess) . error + $ "failed checking out " ++ u ++ " from blob " ++ hash + case paths of + [(_, "1"), (_, "2"), (_, "3")] -> + zipWithM co paths [old, my, your] >> pure () + _ -> error $ "bad data from ls-files for unmerged " ++ u + +gitAdd :: FilePath -> IO () +gitAdd path = do + git <- gitProg + st <- rawSystem git ["add", "--", path] + unless (st == ExitSuccess) $ error "git-add failed" + +{- + - interface to external tokenizers + - + - TODO this might probably enforce joinSpaces? + - or have joinSpaces as configurable? (probably best, default true) + -} +hSplitToFile :: Config -> Handle -> FilePath -> IO () +hSplitToFile cfg h path = + case cfgTokenizer cfg of + TokenizeCharCategory -> internal Toks.splitCategory + TokenizeCharCategorySimple -> internal Toks.splitSimple + TokenizeFilter fltr -> do + st <- + bracketFile path WriteMode $ \ho -> + withCreateProcess + (shell fltr) {std_in = UseHandle h, std_out = UseHandle ho} $ \_ _ _ -> + waitForProcess + unless (st == ExitSuccess) $ error "tokenize filter failed" + where + internal s = hGetContents h >>= writeFile path . Toks.toFile . s diff --git a/Toks.hs b/Toks.hs index bff68e6..54240e1 100644 --- a/Toks.hs +++ b/Toks.hs @@ -15,11 +15,11 @@ unescape :: String -> String unescape [] = [] unescape ('\\':'\\':xs) = '\\' : unescape xs unescape ('\\':'n':xs) = '\n' : unescape xs -unescape ('\\':_) = error "bad escape?" +unescape ('\\':_) = error "bad escape on input" unescape (x:xs) = x : unescape xs markSpace :: String -> Tok -markSpace [] = error "wat" +markSpace [] = error "empty token" markSpace s@(c:_) | isSpace c = '.' : s | otherwise = '|' : s @@ -27,7 +27,7 @@ markSpace s@(c:_) unmarkSpace :: Tok -> String unmarkSpace ('.':s) = s unmarkSpace ('|':s) = s -unmarkSpace x = error "unwat" +unmarkSpace _ = error "bad space marking on input" space :: Tok -> Bool space ('.':_) = True diff --git a/werge.cabal b/werge.cabal index 6202ccc..f8b8c84 100644 --- a/werge.cabal +++ b/werge.cabal @@ -22,8 +22,9 @@ executable werge main-is: Main.hs other-modules: Opts - Toks Paths_werge + Progs + Toks autogen-modules: Paths_werge build-depends: