test

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