fbrnch-0.7.1: src/Git.hs

{-# LANGUAGE CPP #-}

module Git (
#if !MIN_VERSION_simple_cmd(0,2,2)
  gitBool,
#endif
  gitLines,
  gitMergeable,
  gitMergeOrigin,
  gitFetchSilent,
  gitPushSilent,
  gitShortLog,
  gitShortLogN,
  gitShortLog1,
  gitSwitchBranch,
  simplifyCommitLog,
--  checkIsPkgGitDir,
  isGitRepo,
  isPkgGitRepo,
  checkWorkingDirClean,
  isGitDirClean,
  CommitOpt (..),
  module SimpleCmd.Git
  ) where

import Common
import Common.System

import SimpleCmd.Git

import Branches

#if !MIN_VERSION_simple_cmd(0,2,2)
-- | 'gitBool c args' runs git command and return result
gitBool :: String -- ^ git command
        -> [String] -- ^ arguments
        -> IO Bool -- ^ result
gitBool c args =
  cmdBool "git" (c:args)
#endif

gitMergeable :: String -> IO [String]
gitMergeable ref = do
  ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", ref]
  if ancestor then gitShortLog $ "HEAD.." ++ ref
    else return []

gitMergeOrigin :: AnyBranch -> IO ()
gitMergeOrigin br = do
  commits <- gitMergeable $ "origin" </> show br
  unless (null commits) $ do
    rebase <- git "rebase" []
    unless ("Already up to date." `isPrefixOf` rebase) $
      putStr rebase

gitShortLog :: String -> IO [String]
gitShortLog range =
  gitLines "log" ["--pretty=reference", range]

gitShortLogN :: Int -> Maybe String -> IO [String]
gitShortLogN num mrange =
  gitLines "log" (["--max-count=" ++ show num, "--pretty=reference"] ++ maybeToList mrange)

gitShortLog1 :: Maybe String -> IO String
gitShortLog1 mrange =
  git "log" (["--max-count=1", "--pretty=reference"] ++ maybeToList mrange)

-- FIXME currently no-op with --format=reference
simplifyCommitLog :: String -> String
simplifyCommitLog = unwords . shortenHash . words
  where
    shortenHash :: [String] -> [String]
    shortenHash [] = []
    shortenHash (h:cs) = take 8 h : simplifyLog cs

    simplifyLog [] = []
    -- remove leading '('
    simplifyLog (w:ws) =
      case ws of
        [] -> error "malformed changelog"
        [_] -> init (tail w) : map ('(' :) ws
        _ ->
          let (mid,end) = splitAt (length ws - 2) ws
          in tail w : mid ++ [init (head end),'(' : last end]

gitPushSilent :: Maybe String -> IO ()
gitPushSilent mref = do
  putStr "git pushing... "
  out <- cmdQuiet "git" $ ["push", "--quiet", "origin"] ++ maybeToList mref
  putStrLn $ if null out then "done\n" else "\n" ++ out

-- FIXME flag for really silent?
gitFetchSilent :: IO ()
gitFetchSilent = do
  name <- getDirectoryName
  putStr $ "git fetching " ++ name ++ "... "
  (ok, out, err) <- cmdFull "git" ["fetch"] ""
  unless (null out) $ putStrLn out
  unless ok $ error' err
  let filtered = case lines err of
        [] -> []
        (hd:tl) -> filter (/= "Already up to date.") $
                   if "From " `isPrefixOf` hd then tl else hd:tl
  putStrLn $ if null filtered then "done" else "\n" ++ intercalate "\n" filtered

checkWorkingDirClean :: IO ()
checkWorkingDirClean = do
  clean <- isGitDirClean
  unless clean $ do
    dir <- getCurrentDirectory
    error' $ "Working dir is not clean: " ++ dir

isGitDirClean :: IO Bool
isGitDirClean =
  gitBool "diff" ["--quiet", "--exit-code", "HEAD"]

-- checkIsPkgGitDir :: IO ()
-- checkIsPkgGitDir = do
--   pkgGit <- isPkgGitRepo
--   unless pkgGit $ error' "Not a pkg git dir"

isGitRepo :: IO Bool
isGitRepo = isGitDir "." ||^ doesFileExist ".git"

isPkgGitRepo :: IO Bool
isPkgGitRepo = grepGitConfig' "@\\(pkgs\\|src\\)\\."
  where
    -- adapted from SimpleCmd.Git
    grepGitConfig' :: String -> IO Bool
    grepGitConfig' key =
      ifM (isGitDir ".")
      (egrep_ key ".git/config") $
      -- could be a worktree or absorbed submodule (#8)
      ifM (not <$> doesFileExist ".git")
      (return False) $ do
      gitdir <- last . words <$> readFile ".git"
      if "/worktrees/" `isInfixOf` gitdir
        then egrep_ key (takeDirectory (takeDirectory gitdir) </> "config")
        else
        -- absorbed submodule: "gitdir: ../.git/modules/R-bit"
        if "/modules/" `isInfixOf` gitdir then
          egrep_ key $ gitdir </> "config"
          else return False

gitLines :: String -> [String] -> IO [String]
gitLines c args = lines <$> git c args

gitSwitchBranch :: AnyBranch -> IO ()
gitSwitchBranch br = do
  localbranches <- gitLines "branch" ["--format=%(refname:short)"]
  if show br `elem` localbranches then do
    current <- git "rev-parse" ["--abbrev-ref", "HEAD"]
    when (current /= show br) $
      -- cmdSilent
      git_ "checkout" ["-q", show br]
    else do
    -- check remote branch exists
    remotebranch <-
      ifM checkIfRemoteBranchExists
       (return True) $
        gitFetchSilent >> checkIfRemoteBranchExists
    if not remotebranch
      then do
      name <- getDirectoryName
      error' $ name ++ " " ++ show br ++ " branch does not exist!"
      else
      git_ "checkout" ["-q", "-b", show br, "--track", "origin" </> show br]
  where
    checkIfRemoteBranchExists =
      gitBool "show-ref" ["--verify", "--quiet", "refs/remotes/origin/" ++ show br]

data CommitOpt = CommitMsg String | CommitAmend