diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 226 |
1 files changed, 226 insertions, 0 deletions
@@ -0,0 +1,226 @@ +module Main where + +import Control.Monad +import Data.List +import Data.Maybe +import System.Environment +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Text.Read + +import Opts + +{- + - program & directory work + -} +gitProg :: IO String +gitProg = fromMaybe "git" <$> lookupEnv "DELI_GIT" + +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 + (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 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 [] = [] +split p xs = uncurry (:) $ fmap (split p . drop 1) $ break p xs + +uniq (x:xs@(y:_)) + | x == y = uniq xs + | otherwise = x : uniq xs +uniq [x] = [x] +uniq [] = [] + +data SourceItem + = SourceFile FilePath + | SourceRange FilePath Int Int + deriving (Show) + +itemPath (SourceFile p) = p +itemPath (SourceRange p _ _) = p + +sourceItems = start . map words + where + start (("diff":"--git":(a':'/':path):_):ls) = go (SourceFile path) ls + start (_:ls) = start ls + start [] = [] + go f (("diff":"--git":(a':'/':path):_):ls) + | SourceFile _ <- f = f : go (SourceFile path) ls + | otherwise = go (SourceFile path) ls + go f (("@@":('-':inrange):('+':_):"@@":_):ls) + | [Just a, Just b] <- map readMaybe $ split (== ',') inrange + , a /= 0 + , b /= 0 + , r <- SourceRange (itemPath f) a b = r : go r ls + go f (_:ls) = go f ls + go (SourceFile fp) [] = [SourceFile fp] + go _ [] = [] + +blameItem :: FilePath -> SourceItem -> IO [String] +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 = + gitCmdOutput (["merge-base", "--independent"] ++ acc ++ take batch xs) + >>= (`go` drop batch xs) . lines + +diffToSources :: String -> String -> String -> IO [String] +diffToSources base commit bottom = do + -- 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 out + indepCommits (bottom : bis) + +makeEmptyTree :: IO String +makeEmptyTree = + gitCmdOutput ["hash-object", "-w", "-t", "tree", "--stdin"] + >>= singleLine "hash-object tree output" + +makeEmptyCommit :: IO String +makeEmptyCommit = do + et <- makeEmptyTree + let commitObj = + unlines + [ "tree " ++ et + , "author git-deli <git-deli@localhost> 1777294464 +0000" + , "committer git-deli <git-deli@localhost> 1777294464 +0000" + , "" + , "git-deli head commit" + ] + ec <- + gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitObj + >>= singleLine "empty commit hash" + pure ec + +mergedCommitsTree [] = makeEmptyTree +mergedCommitsTree (c:cs) = go c c cs + where + go _ t [] = pure t + go b t (c1:cs) = do + b' <- gitCmdOutput ["merge-base", b, c1] >>= singleLine "merge base" + t' <- + 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 +delinearize head commit bottom = do + parents <- diffToSources head commit bottom + t <- mergedCommitsTree parents + git <- gitProg + -- create a new tree which is essentially commit-head+mergedtree + t' <- + 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' <- 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 + ] + -- label the stuff with a proper commit + commit' <- + gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitMsg + >>= singleLine "transplanted commit hash-object" + -- take the old head + headMsg' <- gitCmdOutput ["cat-file", "commit", head] + -- make a new one + let (hHead, hBody) = break null $ lines headMsg' + 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 + ] + -- write the new head + hcommit' <- + 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 = do + opts <- parseOpts + print opts |