diff options
| -rwxr-xr-x | git-deli | 226 |
1 files changed, 0 insertions, 226 deletions
diff --git a/git-deli b/git-deli deleted file mode 100755 index 8cda60a..0000000 --- a/git-deli +++ /dev/null @@ -1,226 +0,0 @@ -#!/usr/bin/env cabal -{- cabal: -build-depends: base, process, filepath --} -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 Debug.Trace - -{- - - 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 = undefined |