#!/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"

setGitRef :: String -> String -> IO ()
setGitRef refname tgt = do
  git <- gitProg
  st <- rawSystem git ["update-ref", refname, tgt]
  unless (st == ExitSuccess) . fail
    $ "git-update-ref failed for " ++ show (refname, tgt)

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) = do
  git <- gitProg
  (out, st) <-
    withCreateProcess
      (proc git ["log", "-1", "--full-history", "--format=%H", base, "--", path])
        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
      (,) <$> hGetContents' oh <*> waitForProcess p
  unless (st == ExitSuccess) . fail $ "git-log failed on " ++ show (base, path)
  pure $ lines out
blameItem base (SourceRange path r0 r1) = do
  git <- gitProg
  (out, st) <-
    withCreateProcess
      (proc
         git
         ["annotate", "-l", "-L", show r0 ++ "," ++ show r1, base, "--", path])
        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
      (,) <$> hGetContents' oh <*> waitForProcess p
  unless (st == ExitSuccess) . fail
    $ "git-annotate failed on " ++ show (r0, r1, base, path)
  pure . concatMap (take 1 . words) $ lines out

indepCommits :: [String] -> IO [String]
indepCommits = go []
  where
    batch = 32
    go acc [] = pure acc
    go acc xs = do
      git <- gitProg
      (out, st) <-
        withCreateProcess
          (proc git
             $ concat [["merge-base", "--independent"], acc, take batch xs])
            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
          (,) <$> hGetContents' oh <*> waitForProcess p
      unless (st == ExitSuccess) . fail
        $ "git-merge-base failed on " ++ show (acc, take batch xs)
      go (lines out) (drop batch xs)

diffToSources :: String -> String -> IO [String]
diffToSources base commit = do
  git <- gitProg
  (out, st) <-
    withCreateProcess
      (proc git ["diff", "-p", "--no-renames", base, commit])
        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
      (,) <$> hGetContents' oh <*> waitForProcess p
  unless (st == ExitSuccess) . fail
    $ "git-diff failed on " ++ show (base, commit)
  bis <-
    fmap (uniq . sort . uniq . concat) . traverse (blameItem base) . sourceItems
      $ lines out
  indepCommits bis

makeEmptyTree :: IO String
makeEmptyTree = do
  git <- gitProg
  (out, st) <-
    withCreateProcess
      (proc git ["hash-object", "-w", "-t", "tree", "--stdin"])
        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
      (,) <$> hGetContents' oh <*> waitForProcess p
  unless (st == ExitSuccess) . fail $ "git-hash-object tree failed"
  case lines out of
    [x] -> pure x
    _ -> fail "hash-object tree output?"

makeEmptyCommit :: IO String
makeEmptyCommit = do
  et <- makeEmptyTree
  git <- gitProg
  let writeCommit h = do
        hPutStrLn h $ "tree " ++ et
        hPutStrLn h $ "author git-deli <git-deli@localhost> 1777294464 +0000"
        hPutStrLn h $ "committer git-deli <git-deli@localhost> 1777294464 +0000"
        hPutStrLn h $ ""
        hPutStrLn h $ "git-deli head commit"
        hClose h
  (out, st) <-
    withCreateProcess
      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
      (,) <$> (writeCommit ih >> hGetContents' oh) <*> waitForProcess p
  unless (st == ExitSuccess) . fail $ "git-hash-object commit failed"
  ec <-
    case lines out of
      [x] -> pure x
      _ -> fail "hash-object commit output?"
  pure ec

mergedCommitsTree [] = makeEmptyTree
mergedCommitsTree (c:cs) = go c c cs
  where
    go _ t [] = pure t
    go b t (c1:cs) = do
      git <- gitProg
      (out, st) <-
        withCreateProcess
          (proc git ["merge-base", b, c1])
            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
          (,) <$> hGetContents' oh <*> waitForProcess p
      unless (st == ExitSuccess) . fail
        $ "git-merge-base failed with" ++ show (b, c1)
      b' <-
        case lines out of
          [x] -> pure x
          _ -> fail "merge base output?"
      (out, st) <-
        withCreateProcess
          (proc git ["merge-tree", "--write-tree", "--merge-base=" ++ b', t, c1])
            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
          (,) <$> hGetContents' oh <*> waitForProcess p
      unless (st == ExitSuccess) . fail
        $ "git-merge-btree failed with" ++ show (t, c1, b')
      t' <-
        case lines out of
          [x] -> pure x
          _ -> fail "merge-tree output??"
      go b' t' cs

delinearize :: String -> String -> IO String
delinearize head commit = do
  parents <- diffToSources head commit
  t <- mergedCommitsTree parents
  git <- gitProg
  -- create a new tree which is essentially commit-head+mergedtree
  (out, st) <-
    withCreateProcess
      (proc
         git
         ["merge-tree", "--write-tree", "--merge-base=" ++ head, t, commit])
        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
      (,) <$> hGetContents' oh <*> waitForProcess p
  unless (st == ExitSuccess) . fail $ "final git-merge-tree failed"
  t' <-
    case lines out of
      [x] -> pure x
      _ -> fail "final merge-tree returned what?"
  -- now let's get all the data from the original commit and change parents
  (commitMsg', st) <-
    withCreateProcess
      (proc git ["cat-file", "commit", commit])
        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
      (,) <$> hGetContents' oh <*> waitForProcess p
  unless (st == ExitSuccess) . fail $ "git-cat-file failed"
  let (msgHead, msgBody) = break null $ lines commitMsg'
      commitMsg =
        unlines
          $ ["tree " ++ t']
              ++ map ("parent " ++) parents
              ++ filter ((/= ["parent"]) . take 1 . words) msgHead
              ++ msgBody
  -- label the stuff with a proper commit
  (out, st) <-
    withCreateProcess
      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
      (,) <$> (hPutStr ih commitMsg >> hGetContents' oh) <*> waitForProcess p
  unless (st == ExitSuccess) . fail $ "git-hash-object final commit failed"
  commit' <-
    case lines out of
      [x] -> pure x
      _ -> fail "final has-object returned what?"
  -- move the ref!
  pure commit'

main = do
  diffToSources "HEAD^" "HEAD"