sudden outbreak of haskells

1 files changed, 226 insertions, 0 deletions

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 <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