From 335f37c340f8778d158fc3cfe625e50af138bfc4 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Tue, 28 Apr 2026 21:00:35 +0200 Subject: sudden outbreak of haskells --- CHANGELOG.md | 5 ++ Main.hs | 226 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Opts.hs | 21 ++++++ README.md | 3 + git-deli | 2 +- git-deli.cabal | 36 +++++++++ 6 files changed, 292 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.md create mode 100644 Main.hs create mode 100644 Opts.hs create mode 100644 git-deli.cabal diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..1459ff3 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for git-deli + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..1d9557e --- /dev/null +++ b/Main.hs @@ -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 1777294464 +0000" + , "committer git-deli 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 diff --git a/Opts.hs b/Opts.hs new file mode 100644 index 0000000..70dff3f --- /dev/null +++ b/Opts.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module Opts where + +import Paths_clusterpainter (version) +import Data.Version (showVersion) + +import Options.Applicative + +data Opts = Opts deriving Show + +parseOpts :: IO Opts +parseOpts = + customExecParser (prefs $ showHelpOnEmpty) + $ info + (opts <**> helper <**> simpleVersioner (showVersion version)) + (fullDesc + <> header "git-deli -- delinearized git workflow" + <> (footer + "This program is free software; see LICENSE file for details.")) diff --git a/README.md b/README.md index 7932770..9d1106f 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,5 @@ + # `git deli` the git delinearizer +*(your fav chocolate bar with cthulhu flavor)* + diff --git a/git-deli b/git-deli index 1044b2b..8cda60a 100755 --- a/git-deli +++ b/git-deli @@ -73,7 +73,7 @@ data SourceItem itemPath (SourceFile p) = p itemPath (SourceRange p _ _) = p -sourceItems = start . map words . traceShowId +sourceItems = start . map words where start (("diff":"--git":(a':'/':path):_):ls) = go (SourceFile path) ls start (_:ls) = start ls diff --git a/git-deli.cabal b/git-deli.cabal new file mode 100644 index 0000000..837ce16 --- /dev/null +++ b/git-deli.cabal @@ -0,0 +1,36 @@ +cabal-version: 3.0 +name: git-deli +version: 0.1.0.0 +synopsis: git history delinearizer +description: + git-deli is a git frontend for multi-branch workflows. It creates virtual + "view" commits that represent pre-merged state of several branches, and + maintain it over commits that are pushed into the independent branches. + +license: GPL-3.0-or-later +license-file: LICENSE +author: Mirek Kratochvil +maintainer: exa.exa@gmail.com + +-- copyright: +category: Development +build-type: Simple +extra-doc-files: README.md CHANGELOG.md + +common warnings + ghc-options: -Wall + +executable git-deli + import: warnings + main-is: Main.hs + other-modules: Opts + autogen-modules: Paths_git_deli + other-modules: Paths_git_deli + build-depends: + , base >=4.15 && <5 + , filepath + , optparse-applicative + , process + + hs-source-dirs: . + default-language: Haskell2010 -- cgit v1.2.3