From 855d6c26d51a2936f756113d6707e395c95ac561 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Tue, 28 Apr 2026 10:20:02 +0200 Subject: hammer in some software engineering --- git-deli | 269 ++++++++++++++++++++++++++++----------------------------------- 1 file changed, 118 insertions(+), 151 deletions(-) diff --git a/git-deli b/git-deli index cbd35f8..1044b2b 100755 --- a/git-deli +++ b/git-deli @@ -20,12 +20,40 @@ import Debug.Trace gitProg :: IO String gitProg = fromMaybe "git" <$> lookupEnv "DELI_GIT" -setGitRef :: String -> String -> IO () -setGitRef refname tgt = do +gitCmd :: [String] -> IO () +gitCmd args = do + git <- gitProg + st <- rawSystem git args + unless (st == ExitSuccess) . fail $ "git command failed: " ++ show args + +gitCmdOutput :: [String] -> IO String +gitCmdOutput args = do + git <- gitProg + (out, st) <- + withCreateProcess (proc git args) {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> + (,) <$> hGetContents' oh <*> waitForProcess p + unless (st == ExitSuccess) . fail + $ "git output command failed on: " ++ show args + pure out + +gitCmdFilter :: [String] -> String -> IO String +gitCmdFilter args input = do git <- gitProg - st <- rawSystem git ["update-ref", refname, tgt] + (out, st) <- + withCreateProcess + (proc git args) {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p -> + (,) + <$> (hPutStr ih input >> hClose ih >> hGetContents' oh) + <*> waitForProcess p unless (st == ExitSuccess) . fail - $ "git-update-ref failed for " ++ show (refname, tgt) + $ "git filter command failed on: " ++ show args + pure out + +singleLine what = singleObj what . lines + +singleObj :: MonadFail m => String -> [a] -> m a +singleObj _ [x] = pure x +singleObj what _ = fail $ "didn't get a single " ++ what split :: (Char -> Bool) -> String -> [String] split p [] = [] @@ -45,7 +73,7 @@ data SourceItem itemPath (SourceFile p) = p itemPath (SourceRange p _ _) = p -sourceItems = start . map words +sourceItems = start . map words . traceShowId where start (("diff":"--git":(a':'/':path):_):ls) = go (SourceFile path) ls start (_:ls) = start ls @@ -63,94 +91,59 @@ sourceItems = start . map words go _ [] = [] blameItem :: FilePath -> SourceItem -> IO [String] -blameItem base (SourceFile path) = do - git <- gitProg - (out, st) <- - withCreateProcess - (proc git ["log", "-1", "--full-history", "--format=%H", base, "--", path]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-log failed on " ++ show (base, path) - pure $ lines out -blameItem base (SourceRange path r0 r1) = do - git <- gitProg - (out, st) <- - withCreateProcess - (proc - git - ["annotate", "-l", "-L", show r0 ++ "," ++ show r1, base, "--", path]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail - $ "git-annotate failed on " ++ show (r0, r1, base, path) - pure . concatMap (take 1 . words) $ lines out +blameItem base (SourceFile path) = + lines + <$> gitCmdOutput + ["log", "-1", "--full-history", "--format=%H", base, "--", path] +blameItem base (SourceRange path r0 r1) = + concatMap (take 1 . words) . lines + <$> gitCmdOutput + [ "annotate" + , "-l" + , "-L" + , show r0 ++ "," ++ show (r0 + r1 - 1) + , base + , "--" + , path + ] indepCommits :: [String] -> IO [String] indepCommits = go [] where batch = 32 go acc [] = pure acc - go acc xs = do - git <- gitProg - (out, st) <- - withCreateProcess - (proc git - $ concat [["merge-base", "--independent"], acc, take batch xs]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail - $ "git-merge-base failed on " ++ show (acc, take batch xs) - go (lines out) (drop batch xs) + go acc xs = + gitCmdOutput (["merge-base", "--independent"] ++ acc ++ take batch xs) + >>= (`go` drop batch xs) . lines diffToSources :: String -> String -> String -> IO [String] diffToSources base commit bottom = do - git <- gitProg - (out, st) <- - withCreateProcess - (proc git ["diff", "-p", "--no-renames", base, commit]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail - $ "git-diff failed on " ++ show (base, commit) + -- TODO: looks quite like this sometimes selects the head, which is ofc an issue + out <- lines <$> gitCmdOutput ["diff", "-p", "--no-renames", base, commit] bis <- - fmap (uniq . sort . uniq . concat) . traverse (blameItem base) . sourceItems - $ lines out - indepCommits (bottom:bis) + fmap (uniq . sort . uniq . concat) . traverse (blameItem base) + $ sourceItems out + indepCommits (bottom : bis) makeEmptyTree :: IO String -makeEmptyTree = do - git <- gitProg - (out, st) <- - withCreateProcess - (proc git ["hash-object", "-w", "-t", "tree", "--stdin"]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-hash-object tree failed" - case lines out of - [x] -> pure x - _ -> fail "hash-object tree output?" +makeEmptyTree = + gitCmdOutput ["hash-object", "-w", "-t", "tree", "--stdin"] + >>= singleLine "hash-object tree output" makeEmptyCommit :: IO String makeEmptyCommit = do et <- makeEmptyTree - git <- gitProg - let writeCommit h = do - hPutStrLn h $ "tree " ++ et - hPutStrLn h $ "author git-deli 1777294464 +0000" - hPutStrLn h $ "committer git-deli 1777294464 +0000" - hPutStrLn h $ "" - hPutStrLn h $ "git-deli head commit" - hClose h - (out, st) <- - withCreateProcess - (proc git ["hash-object", "-w", "-t", "commit", "--stdin"]) - {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p -> - (,) <$> (writeCommit ih >> hGetContents' oh) <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-hash-object commit failed" + let commitObj = + unlines + [ "tree " ++ et + , "author git-deli 1777294464 +0000" + , "committer git-deli 1777294464 +0000" + , "" + , "git-deli head commit" + ] ec <- - case lines out of - [x] -> pure x - _ -> fail "hash-object commit output?" + gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitObj + >>= singleLine "empty commit hash" pure ec mergedCommitsTree [] = makeEmptyTree @@ -158,29 +151,17 @@ mergedCommitsTree (c:cs) = go c c cs where go _ t [] = pure t go b t (c1:cs) = do - git <- gitProg - (out, st) <- - withCreateProcess - (proc git ["merge-base", b, c1]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail - $ "git-merge-base failed with" ++ show (b, c1) - b' <- - case lines out of - [x] -> pure x - _ -> fail "merge base output?" - (out, st) <- - withCreateProcess - (proc git ["merge-tree", "--write-tree", "-Xno-renames", "--merge-base=" ++ b', t, c1]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail - $ "git-merge-btree failed with" ++ show (t, c1, b') + b' <- gitCmdOutput ["merge-base", b, c1] >>= singleLine "merge base" t' <- - case lines out of - [x] -> pure x - _ -> fail "merge-tree output??" + gitCmdOutput + [ "merge-tree" + , "--write-tree" + , "-Xno-renames" + , "--merge-base=" ++ b' + , t + , c1 + ] + >>= singleLine "merged tree hash" go b' t' cs delinearize :: String -> String -> String -> IO String @@ -189,71 +170,57 @@ delinearize head commit bottom = do t <- mergedCommitsTree parents git <- gitProg -- create a new tree which is essentially commit-head+mergedtree - (out, st) <- - withCreateProcess - (proc - git - ["merge-tree", "--write-tree", "-Xno-renames", "--merge-base=" ++ head, t, commit]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "final git-merge-tree failed" ++ show (head,t,commit) t' <- - case lines out of - [x] -> pure x - _ -> fail "final merge-tree returned what?" + gitCmdOutput + [ "merge-tree" + , "--write-tree" + , "-Xno-renames" + , "--merge-base=" ++ head + , t + , commit + ] + >>= singleLine "transplanted tree hash" -- now let's get all the data from the original commit and change parents - (commitMsg', st) <- - withCreateProcess - (proc git ["cat-file", "commit", commit]) - {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p -> - (,) <$> hGetContents' oh <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-cat-file failed" + commitMsg' <- gitCmdOutput ["cat-file", "commit", commit] let (msgHead, msgBody) = break null $ lines commitMsg' commitMsg = - unlines $ concat - [["tree " ++ t'], - map ("parent " ++) parents - , filter (not . flip elem [["parent"], ["tree"]] . take 1 . words) msgHead - , msgBody ] + unlines + $ concat + [ ["tree " ++ t'] + , map ("parent " ++) parents + , filter + (not . flip elem [["parent"], ["tree"]] . take 1 . words) + msgHead + , msgBody + ] -- label the stuff with a proper commit - (out, st) <- - withCreateProcess - (proc git ["hash-object", "-w", "-t", "commit", "--stdin"]) - {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p -> - (,) <$> (hPutStr ih commitMsg >> hClose ih >> hGetContents' oh) <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-hash-object final commit failed" commit' <- - case lines out of - [x] -> pure x - _ -> fail "final has-object returned what?" + gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitMsg + >>= singleLine "transplanted commit hash-object" -- take the old head - (headMsg',st) <- - withCreateProcess - (proc git ["cat-file", "commit", head]) - {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p -> - (,) <$> (hPutStr ih commitMsg >> hClose ih >> hGetContents' oh) <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-cat-file old head failed" + headMsg' <- gitCmdOutput ["cat-file", "commit", head] -- make a new one let (hHead, hBody) = break null $ lines headMsg' - getP ["parent",x] = [x] + getP ["parent", x] = [x] getP _ = [] - hParents <- indepCommits . (commit':) $ concatMap (getP.words) hHead - let headMsg = unlines $ concat - [ filter ((==["tree"]) . take 1 . words) msgHead - , map ("parent "++) hParents - , filter (not . flip elem [["parent"], ["tree"]] . take 1 . words) hHead - , hBody ] + hParents <- indepCommits . (commit' :) $ concatMap (getP . words) hHead + let headMsg = + unlines + $ concat + [ filter ((== ["tree"]) . take 1 . words) msgHead + , map ("parent " ++) hParents + , filter + (not . flip elem [["parent"], ["tree"]] . take 1 . words) + hHead + , hBody + ] -- write the new head - (out, st) <- - withCreateProcess - (proc git ["hash-object", "-w", "-t", "commit", "--stdin"]) - {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p -> - (,) <$> (hPutStr ih headMsg >> hClose ih >> hGetContents' oh) <*> waitForProcess p - unless (st == ExitSuccess) . fail $ "git-hash-object new head commit failed" hcommit' <- - case lines out of - [x] -> pure x - _ -> fail "hash-object new head returned what?" + gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] headMsg + >>= singleLine "new head hash-object" pure hcommit' +setGitRef :: String -> String -> IO () +setGitRef refname tgt = gitCmd ["update-ref", refname, tgt] + main = undefined -- cgit v1.2.3