{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}

module Mit.Git where

import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.ANSI as Text
import qualified Data.Text.IO as Text
import qualified Ki
import Mit.Globals (debug)
import Mit.Prelude
import Mit.Process
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.IO (Handle, hClose, hIsEOF)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Process (getProcessGroupIDOf)
import System.Posix.Signals
import System.Posix.Terminal (queryTerminal)
import System.Process
import System.Process.Internals

gitdir :: Text
gitdir :: Text
gitdir =
  IO Text -> Text
forall a. IO a -> a
unsafePerformIO ([Text] -> IO Text
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"--absolute-git-dir"])
{-# NOINLINE gitdir #-}

-- | The root of this git worktree.
rootdir :: Text
rootdir :: Text
rootdir =
  IO Text -> Text
forall a. IO a -> a
unsafePerformIO ([Text] -> IO Text
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"--show-toplevel"])
{-# NOINLINE rootdir #-}

data DiffResult
  = Differences
  | NoDifferences

data GitCommitInfo = GitCommitInfo
  { GitCommitInfo -> Text
author :: Text,
    GitCommitInfo -> Text
date :: Text,
    GitCommitInfo -> Text
hash :: Text,
    GitCommitInfo -> Text
shorthash :: Text,
    GitCommitInfo -> Text
subject :: Text
  }
  deriving stock (Int -> GitCommitInfo -> ShowS
[GitCommitInfo] -> ShowS
GitCommitInfo -> String
(Int -> GitCommitInfo -> ShowS)
-> (GitCommitInfo -> String)
-> ([GitCommitInfo] -> ShowS)
-> Show GitCommitInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitCommitInfo] -> ShowS
$cshowList :: [GitCommitInfo] -> ShowS
show :: GitCommitInfo -> String
$cshow :: GitCommitInfo -> String
showsPrec :: Int -> GitCommitInfo -> ShowS
$cshowsPrec :: Int -> GitCommitInfo -> ShowS
Show)

prettyGitCommitInfo :: GitCommitInfo -> Text
prettyGitCommitInfo :: GitCommitInfo -> Text
prettyGitCommitInfo GitCommitInfo
info =
  -- FIXME use builder
  [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Text -> Text
Text.bold (Text -> Text
Text.black GitCommitInfo
info.shorthash),
      Text
" ",
      Text -> Text
Text.bold (Text -> Text
Text.white GitCommitInfo
info.subject),
      Text
" - ",
      Text -> Text
Text.italic (Text -> Text
Text.white GitCommitInfo
info.author),
      Text
" ",
      Text -> Text
Text.italic (Text -> Text
Text.yellow GitCommitInfo
info.date) -- FIXME some other color, magenta?
    ]

data GitConflict
  = GitConflict GitConflictXY Text
  deriving stock (GitConflict -> GitConflict -> Bool
(GitConflict -> GitConflict -> Bool)
-> (GitConflict -> GitConflict -> Bool) -> Eq GitConflict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitConflict -> GitConflict -> Bool
$c/= :: GitConflict -> GitConflict -> Bool
== :: GitConflict -> GitConflict -> Bool
$c== :: GitConflict -> GitConflict -> Bool
Eq, Int -> GitConflict -> ShowS
[GitConflict] -> ShowS
GitConflict -> String
(Int -> GitConflict -> ShowS)
-> (GitConflict -> String)
-> ([GitConflict] -> ShowS)
-> Show GitConflict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitConflict] -> ShowS
$cshowList :: [GitConflict] -> ShowS
show :: GitConflict -> String
$cshow :: GitConflict -> String
showsPrec :: Int -> GitConflict -> ShowS
$cshowsPrec :: Int -> GitConflict -> ShowS
Show)

parseGitConflict :: Text -> Maybe GitConflict
parseGitConflict :: Text -> Maybe GitConflict
parseGitConflict Text
line = do
  [Text
xy, Text
name] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Text -> [Text]
Text.words Text
line)
  GitConflictXY -> Text -> GitConflict
GitConflict (GitConflictXY -> Text -> GitConflict)
-> Maybe GitConflictXY -> Maybe (Text -> GitConflict)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe GitConflictXY
parseGitConflictXY Text
xy Maybe (Text -> GitConflict) -> Maybe Text -> Maybe GitConflict
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name

-- FIXME builder
showGitConflict :: GitConflict -> Text
showGitConflict :: GitConflict -> Text
showGitConflict (GitConflict GitConflictXY
xy Text
name) =
  Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitConflictXY -> Text
showGitConflictXY GitConflictXY
xy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

data GitConflictXY
  = AA -- both added
  | AU -- added by us
  | DD -- both deleted
  | DU -- deleted by us
  | UA -- added by them
  | UD -- deleted by them
  | UU -- both modified
  deriving stock (GitConflictXY -> GitConflictXY -> Bool
(GitConflictXY -> GitConflictXY -> Bool)
-> (GitConflictXY -> GitConflictXY -> Bool) -> Eq GitConflictXY
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitConflictXY -> GitConflictXY -> Bool
$c/= :: GitConflictXY -> GitConflictXY -> Bool
== :: GitConflictXY -> GitConflictXY -> Bool
$c== :: GitConflictXY -> GitConflictXY -> Bool
Eq, Int -> GitConflictXY -> ShowS
[GitConflictXY] -> ShowS
GitConflictXY -> String
(Int -> GitConflictXY -> ShowS)
-> (GitConflictXY -> String)
-> ([GitConflictXY] -> ShowS)
-> Show GitConflictXY
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitConflictXY] -> ShowS
$cshowList :: [GitConflictXY] -> ShowS
show :: GitConflictXY -> String
$cshow :: GitConflictXY -> String
showsPrec :: Int -> GitConflictXY -> ShowS
$cshowsPrec :: Int -> GitConflictXY -> ShowS
Show)

parseGitConflictXY :: Text -> Maybe GitConflictXY
parseGitConflictXY :: Text -> Maybe GitConflictXY
parseGitConflictXY = \case
  Text
"AA" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
AA
  Text
"AU" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
AU
  Text
"DD" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
DD
  Text
"DU" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
DU
  Text
"UA" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
UA
  Text
"UD" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
UD
  Text
"UU" -> GitConflictXY -> Maybe GitConflictXY
forall a. a -> Maybe a
Just GitConflictXY
UU
  Text
_ -> Maybe GitConflictXY
forall a. Maybe a
Nothing

-- FIXME builder
showGitConflictXY :: GitConflictXY -> Text
showGitConflictXY :: GitConflictXY -> Text
showGitConflictXY = \case
  GitConflictXY
AA -> Text
"both added"
  GitConflictXY
AU -> Text
"added by us"
  GitConflictXY
DD -> Text
"both deleted"
  GitConflictXY
DU -> Text
"deleted by us"
  GitConflictXY
UA -> Text
"added by them"
  GitConflictXY
UD -> Text
"deleted by them"
  GitConflictXY
UU -> Text
"both modified"

data GitVersion
  = GitVersion Int Int Int
  deriving stock (GitVersion -> GitVersion -> Bool
(GitVersion -> GitVersion -> Bool)
-> (GitVersion -> GitVersion -> Bool) -> Eq GitVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitVersion -> GitVersion -> Bool
$c/= :: GitVersion -> GitVersion -> Bool
== :: GitVersion -> GitVersion -> Bool
$c== :: GitVersion -> GitVersion -> Bool
Eq, Eq GitVersion
Eq GitVersion
-> (GitVersion -> GitVersion -> Ordering)
-> (GitVersion -> GitVersion -> Bool)
-> (GitVersion -> GitVersion -> Bool)
-> (GitVersion -> GitVersion -> Bool)
-> (GitVersion -> GitVersion -> Bool)
-> (GitVersion -> GitVersion -> GitVersion)
-> (GitVersion -> GitVersion -> GitVersion)
-> Ord GitVersion
GitVersion -> GitVersion -> Bool
GitVersion -> GitVersion -> Ordering
GitVersion -> GitVersion -> GitVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GitVersion -> GitVersion -> GitVersion
$cmin :: GitVersion -> GitVersion -> GitVersion
max :: GitVersion -> GitVersion -> GitVersion
$cmax :: GitVersion -> GitVersion -> GitVersion
>= :: GitVersion -> GitVersion -> Bool
$c>= :: GitVersion -> GitVersion -> Bool
> :: GitVersion -> GitVersion -> Bool
$c> :: GitVersion -> GitVersion -> Bool
<= :: GitVersion -> GitVersion -> Bool
$c<= :: GitVersion -> GitVersion -> Bool
< :: GitVersion -> GitVersion -> Bool
$c< :: GitVersion -> GitVersion -> Bool
compare :: GitVersion -> GitVersion -> Ordering
$ccompare :: GitVersion -> GitVersion -> Ordering
$cp1Ord :: Eq GitVersion
Ord)

showGitVersion :: GitVersion -> Text
showGitVersion :: GitVersion -> Text
showGitVersion (GitVersion Int
x Int
y Int
z) =
  String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
y) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
z)

-- | Apply stash, return conflicts.
gitApplyStash :: Text -> IO [GitConflict]
gitApplyStash :: Text -> IO [GitConflict]
gitApplyStash Text
stash = do
  [GitConflict]
conflicts <-
    [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"stash", Text
"apply", Text
stash] IO Bool -> (Bool -> IO [GitConflict]) -> IO [GitConflict]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> IO [GitConflict]
gitConflicts
      Bool
True -> [GitConflict] -> IO [GitConflict]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  IO ()
gitUnstageChanges
  [GitConflict] -> IO [GitConflict]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [GitConflict]
conflicts

-- | Create a branch.
gitBranch :: Text -> IO ()
gitBranch :: Text -> IO ()
gitBranch Text
branch =
  [Text] -> IO ()
git_ [Text
"branch", Text
"--no-track", Text
branch]

-- | Does the given local branch (refs/heads/...) exist?
gitBranchExists :: Text -> IO Bool
gitBranchExists :: Text -> IO Bool
gitBranchExists Text
branch =
  [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"--verify", Text
"refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch]

-- | Get the head of a local branch (refs/heads/...).
gitBranchHead :: Text -> IO (Maybe Text)
gitBranchHead :: Text -> IO (Maybe Text)
gitBranchHead Text
branch =
  [Text] -> IO (Either ExitCode Text)
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch] IO (Either ExitCode Text)
-> (Either ExitCode Text -> Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left ExitCode
_ -> Maybe Text
forall a. Maybe a
Nothing
    Right Text
head -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
head

-- | Get the directory a branch's worktree is checked out in, if it exists.
gitBranchWorktreeDir :: Text -> IO (Maybe Text)
gitBranchWorktreeDir :: Text -> IO (Maybe Text)
gitBranchWorktreeDir Text
branch = do
  [GitWorktree]
worktrees <- IO [GitWorktree]
gitWorktreeList
  case (GitWorktree -> Bool) -> [GitWorktree] -> Maybe GitWorktree
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\GitWorktree
worktree -> GitWorktree
worktree.branch Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch) [GitWorktree]
worktrees of
    Maybe GitWorktree
Nothing -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Just GitWorktree
worktree -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just GitWorktree
worktree.directory)

gitCommit :: IO Bool
gitCommit :: IO Bool
gitCommit =
  Fd -> IO Bool
queryTerminal Fd
0 IO Bool -> (Bool -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> do
      Maybe String
message <- String -> IO (Maybe String)
lookupEnv String
"MIT_COMMIT_MESSAGE"
      [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"commit", Text
"--all", Text
"--message", Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" String -> Text
Text.pack Maybe String
message]
    Bool
True ->
      [Text] -> IO ExitCode
git2 [Text
"commit", Text
"--patch", Text
"--quiet"] IO ExitCode -> (ExitCode -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        ExitFailure Int
_ -> Bool
False
        ExitCode
ExitSuccess -> Bool
True

gitCommitsBetween :: Maybe Text -> Text -> IO (Seq GitCommitInfo)
gitCommitsBetween :: Maybe Text -> Text -> IO (Seq GitCommitInfo)
gitCommitsBetween Maybe Text
commit1 Text
commit2 =
  if Maybe Text
commit1 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
commit2
    then Seq GitCommitInfo -> IO (Seq GitCommitInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq GitCommitInfo
forall a. Seq a
Seq.empty
    else do
      Seq Text
commits <-
        -- --first-parent seems desirable for topic branches
        [Text] -> IO (Seq Text)
forall a. ProcessOutput a => [Text] -> IO a
git
          [ Text
"rev-list",
            Text
"--color=always",
            Text
"--date=human",
            Text
"--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s",
            Text
"--max-count=11",
            (Text -> Text)
-> (Text -> Text -> Text) -> Maybe Text -> Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> Text
forall a. a -> a
id (\Text
c1 Text
c2 -> Text
c1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c2) Maybe Text
commit1 Text
commit2
          ]
      Seq GitCommitInfo -> IO (Seq GitCommitInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GitCommitInfo
parseCommitInfo (Text -> GitCommitInfo) -> Seq Text -> Seq GitCommitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Text -> Seq Text
forall a. Seq a -> Seq a
dropEvens Seq Text
commits)
  where
    -- git rev-list with a custom format prefixes every commit with a redundant line :|
    dropEvens :: Seq a -> Seq a
    dropEvens :: Seq a -> Seq a
dropEvens = \case
      a
_ Seq.:<| a
x Seq.:<| Seq a
xs -> a
x a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
Seq.<| Seq a -> Seq a
forall a. Seq a -> Seq a
dropEvens Seq a
xs
      Seq a
xs -> Seq a
xs
    parseCommitInfo :: Text -> GitCommitInfo
    parseCommitInfo :: Text -> GitCommitInfo
parseCommitInfo Text
line =
      case (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\xFEFF') Text
line of
        [Text
author, Text
date, Text
hash, Text
shorthash, Text
subject] -> GitCommitInfo :: Text -> Text -> Text -> Text -> Text -> GitCommitInfo
GitCommitInfo {Text
author :: Text
$sel:author:GitCommitInfo :: Text
author, Text
date :: Text
$sel:date:GitCommitInfo :: Text
date, Text
hash :: Text
$sel:hash:GitCommitInfo :: Text
hash, Text
shorthash :: Text
$sel:shorthash:GitCommitInfo :: Text
shorthash, Text
subject :: Text
$sel:subject:GitCommitInfo :: Text
subject}
        [Text]
_ -> String -> GitCommitInfo
forall a. HasCallStack => String -> a
error (Text -> String
Text.unpack Text
line)

gitConflicts :: IO [GitConflict]
gitConflicts :: IO [GitConflict]
gitConflicts =
  (Text -> Maybe GitConflict) -> [Text] -> [GitConflict]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe GitConflict
parseGitConflict ([Text] -> [GitConflict]) -> IO [Text] -> IO [GitConflict]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> IO [Text]
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"status", Text
"--no-renames", Text
"--porcelain=v1"]

gitCreateStash :: IO Text
gitCreateStash :: IO Text
gitCreateStash = do
  [Text] -> IO ()
git_ [Text
"add", Text
"--all"] -- it seems certain things (like renames), unless staged, cannot be stashed
  Text
stash <- [Text] -> IO Text
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"stash", Text
"create"]
  IO ()
gitUnstageChanges
  Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
stash

-- | Get the current branch.
gitCurrentBranch :: IO Text
gitCurrentBranch :: IO Text
gitCurrentBranch =
  [Text] -> IO Text
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"branch", Text
"--show-current"]

-- FIXME document this
gitDiff :: IO DiffResult
gitDiff :: IO DiffResult
gitDiff = do
  IO ()
gitUnstageChanges
  [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"diff", Text
"--quiet"] IO Bool -> (Bool -> DiffResult) -> IO DiffResult
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Bool
False -> DiffResult
Differences
    Bool
True -> DiffResult
NoDifferences

gitExistCommitsBetween :: Text -> Text -> IO Bool
gitExistCommitsBetween :: Text -> Text -> IO Bool
gitExistCommitsBetween Text
commit1 Text
commit2 =
  if Text
commit1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
commit2
    then Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> IO (Maybe Text) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> IO (Maybe Text)
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-list", Text
"--max-count=1", Text
commit1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit2]

-- | Do any untracked files exist?
gitExistUntrackedFiles :: IO Bool
gitExistUntrackedFiles :: IO Bool
gitExistUntrackedFiles =
  Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> IO [Text] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Text]
gitListUntrackedFiles

gitFetch :: Text -> IO Bool
gitFetch :: Text -> IO Bool
gitFetch Text
remote =
  [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"fetch", Text
remote]

gitFetch_ :: Text -> IO ()
gitFetch_ :: Text -> IO ()
gitFetch_ =
  IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> (Text -> IO Bool) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO Bool
gitFetch

gitHead :: IO Text
gitHead :: IO Text
gitHead =
  [Text] -> IO Text
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"HEAD"]

-- | List all untracked files.
gitListUntrackedFiles :: IO [Text]
gitListUntrackedFiles :: IO [Text]
gitListUntrackedFiles =
  [Text] -> IO [Text]
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"ls-files", Text
"--exclude-standard", Text
"--other"]

-- FIXME document what this does
gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ())
gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ())
gitMerge Text
me Text
target = do
  [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"merge", Text
"--ff", Text
"--no-commit", Text
target] IO Bool
-> (Bool -> IO (Either (IO [GitConflict]) ()))
-> IO (Either (IO [GitConflict]) ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False ->
      (Either (IO [GitConflict]) () -> IO (Either (IO [GitConflict]) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (IO [GitConflict]) () -> IO (Either (IO [GitConflict]) ()))
-> (IO [GitConflict] -> Either (IO [GitConflict]) ())
-> IO [GitConflict]
-> IO (Either (IO [GitConflict]) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [GitConflict] -> Either (IO [GitConflict]) ()
forall a b. a -> Either a b
Left) do
        [GitConflict]
conflicts <- IO [GitConflict]
gitConflicts
        [Text] -> IO ()
git_ [Text
"add", Text
"--all"]
        [Text] -> IO ()
git_ [Text
"commit", Text
"--no-edit", Text
"--message", [GitConflict] -> Text
mergeMessage [GitConflict]
conflicts]
        [GitConflict] -> IO [GitConflict]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [GitConflict]
conflicts
    Bool
True -> do
      IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitMergeInProgress ([Text] -> IO ()
git_ [Text
"commit", Text
"--message", [GitConflict] -> Text
mergeMessage []])
      Either (IO [GitConflict]) () -> IO (Either (IO [GitConflict]) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either (IO [GitConflict]) ()
forall a b. b -> Either a b
Right ())
  where
    mergeMessage :: [GitConflict] -> Text
    mergeMessage :: [GitConflict] -> Text
mergeMessage [GitConflict]
conflicts =
      -- FIXME use builder
      [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ Text
"⅄",
          if [GitConflict] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GitConflict]
conflicts then Text
"" else Text
"\x0338",
          Text
" ",
          if Text
target' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
me then Text
me else Text
target' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
me,
          if [GitConflict] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GitConflict]
conflicts
            then Text
""
            else
              Text
" (conflicts)\n\nConflicting files:\n"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"\n" ((GitConflict -> Text) -> [GitConflict] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (GitConflict -> Text) -> GitConflict -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitConflict -> Text
showGitConflict) [GitConflict]
conflicts)
        ]
      where
        target' :: Text
        target' :: Text
target' =
          Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
target (Text -> Text -> Maybe Text
Text.stripPrefix Text
"origin/" Text
target)

gitMergeInProgress :: IO Bool
gitMergeInProgress :: IO Bool
gitMergeInProgress =
  String -> IO Bool
doesFileExist (Text -> String
Text.unpack (Text
gitdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/MERGE_HEAD"))

gitPush :: Text -> IO Bool
gitPush :: Text -> IO Bool
gitPush Text
branch =
  [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"push", Text
"--set-upstream", Text
"origin", Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch]

-- | Does the given remote branch (refs/remotes/...) exist?
gitRemoteBranchExists :: Text -> Text -> IO Bool
gitRemoteBranchExists :: Text -> Text -> IO Bool
gitRemoteBranchExists Text
remote Text
branch =
  [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"--verify", Text
"refs/remotes/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
remote Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch]

-- | Get the head of a remote branch.
gitRemoteBranchHead :: Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead :: Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
remote Text
branch =
  [Text] -> IO (Either ExitCode Text)
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
"refs/remotes/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
remote Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch] IO (Either ExitCode Text)
-> (Either ExitCode Text -> Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left ExitCode
_ -> Maybe Text
forall a. Maybe a
Nothing
    Right Text
head -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
head

-- | Blow away untracked files, and hard-reset to the given commit
gitResetHard :: Text -> IO ()
gitResetHard :: Text -> IO ()
gitResetHard Text
commit = do
  [Text] -> IO ()
git_ [Text
"clean", Text
"-d", Text
"--force"]
  [Text] -> IO ()
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"reset", Text
"--hard", Text
commit]

gitRevert :: Text -> IO ()
gitRevert :: Text -> IO ()
gitRevert Text
commit =
  [Text] -> IO ()
git_ [Text
"revert", Text
commit]

-- | Stash uncommitted changes (if any).
gitStash :: IO (Maybe Text)
gitStash :: IO (Maybe Text)
gitStash = do
  IO DiffResult
gitDiff IO DiffResult -> (DiffResult -> IO (Maybe Text)) -> IO (Maybe Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DiffResult
Differences -> do
      Text
stash <- IO Text
gitCreateStash
      Text -> IO ()
gitResetHard Text
"HEAD"
      Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stash)
    DiffResult
NoDifferences -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing

gitSwitch :: Text -> IO ()
gitSwitch :: Text -> IO ()
gitSwitch Text
branch =
  [Text] -> IO ()
git_ [Text
"switch", Text
branch]

gitUnstageChanges :: IO ()
gitUnstageChanges :: IO ()
gitUnstageChanges = do
  [Text] -> IO ()
git_ [Text
"reset", Text
"--mixed"]
  [Text]
untrackedFiles <- IO [Text]
gitListUntrackedFiles
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
untrackedFiles) ([Text] -> IO ()
git_ (Text
"add" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"--intent-to-add" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
untrackedFiles))

gitVersion :: IO GitVersion
gitVersion :: IO GitVersion
gitVersion = do
  Text
v0 <- [Text] -> IO Text
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"--version"]
  IO GitVersion -> Maybe (IO GitVersion) -> IO GitVersion
forall a. a -> Maybe a -> a
fromMaybe (IOError -> IO GitVersion
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError (String
"Could not parse git version from: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
v0))) do
    [Text
"git", Text
"version", Text
v1] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Text -> [Text]
Text.words Text
v0)
    [Text
sx, Text
sy, Text
sz] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ((Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
v1)
    Int
x <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
sx)
    Int
y <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
sy)
    Int
z <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
sz)
    IO GitVersion -> Maybe (IO GitVersion)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitVersion -> IO GitVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int -> GitVersion
GitVersion Int
x Int
y Int
z))

data GitWorktree = GitWorktree
  { GitWorktree -> Maybe Text
branch :: Maybe Text,
    GitWorktree -> Text
commit :: Text,
    GitWorktree -> Text
directory :: Text
  }

-- /dir/one 0efd393c35 [oingo]         -> ("/dir/one", "0efd393c35", Just "oingo")
-- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing)
gitWorktreeList :: IO [GitWorktree]
gitWorktreeList :: IO [GitWorktree]
gitWorktreeList = do
  (Text -> GitWorktree) -> [Text] -> [GitWorktree]
forall a b. (a -> b) -> [a] -> [b]
map Text -> GitWorktree
f ([Text] -> [GitWorktree]) -> IO [Text] -> IO [GitWorktree]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> IO [Text]
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"worktree", Text
"list"]
  where
    f :: Text -> GitWorktree
    f :: Text -> GitWorktree
f Text
line =
      case Text -> [Text]
Text.words Text
line of
        [Text
directory, Text
commit, Text -> Maybe Text
stripBrackets -> Just Text
branch] -> GitWorktree :: Maybe Text -> Text -> Text -> GitWorktree
GitWorktree {$sel:branch:GitWorktree :: Maybe Text
branch = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch, Text
commit :: Text
$sel:commit:GitWorktree :: Text
commit, Text
directory :: Text
$sel:directory:GitWorktree :: Text
directory}
        [Text
directory, Text
commit, Text
"(detached", Text
"HEAD)"] -> GitWorktree :: Maybe Text -> Text -> Text -> GitWorktree
GitWorktree {$sel:branch:GitWorktree :: Maybe Text
branch = Maybe Text
forall a. Maybe a
Nothing, Text
commit :: Text
$sel:commit:GitWorktree :: Text
commit, Text
directory :: Text
$sel:directory:GitWorktree :: Text
directory}
        [Text]
_ -> String -> GitWorktree
forall a. HasCallStack => String -> a
error (Text -> String
Text.unpack Text
line)
      where
        stripBrackets :: Text -> Maybe Text
        stripBrackets :: Text -> Maybe Text
stripBrackets =
          Text -> Text -> Maybe Text
Text.stripPrefix Text
"[" (Text -> Maybe Text) -> (Text -> Maybe Text) -> Text -> Maybe Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Text -> Maybe Text
Text.stripSuffix Text
"]"

-- git@github.com:mitchellwrosen/mit.git -> Just ("git@github.com:mitchellwrosen/mit.git", "mit")
parseGitRepo :: Text -> Maybe (Text, Text)
parseGitRepo :: Text -> Maybe (Text, Text)
parseGitRepo Text
url = do
  Text
url' <- Text -> Text -> Maybe Text
Text.stripSuffix Text
".git" Text
url
  (Text, Text) -> Maybe (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
url, (Char -> Bool) -> Text -> Text
Text.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
url')

git :: ProcessOutput a => [Text] -> IO a
git :: [Text] -> IO a
git [Text]
args = do
  let spec :: CreateProcess
      spec :: CreateProcess
spec =
        CreateProcess :: CmdSpec
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe GroupID
-> Maybe UserID
-> Bool
-> CreateProcess
CreateProcess
          { child_group :: Maybe GroupID
child_group = Maybe GroupID
forall a. Maybe a
Nothing,
            child_user :: Maybe UserID
child_user = Maybe UserID
forall a. Maybe a
Nothing,
            close_fds :: Bool
close_fds = Bool
True,
            cmdspec :: CmdSpec
cmdspec = String -> [String] -> CmdSpec
RawCommand String
"git" ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack [Text]
args),
            create_group :: Bool
create_group = Bool
False,
            cwd :: Maybe String
cwd = Maybe String
forall a. Maybe a
Nothing,
            delegate_ctlc :: Bool
delegate_ctlc = Bool
False,
            env :: Maybe [(String, String)]
env = Maybe [(String, String)]
forall a. Maybe a
Nothing,
            new_session :: Bool
new_session = Bool
False,
            std_err :: StdStream
std_err = StdStream
CreatePipe,
            std_in :: StdStream
std_in = StdStream
NoStream,
            std_out :: StdStream
std_out = StdStream
CreatePipe,
            -- windows-only
            create_new_console :: Bool
create_new_console = Bool
False,
            detach_console :: Bool
detach_console = Bool
False,
            use_process_jobs :: Bool
use_process_jobs = Bool
False
          }
  IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
spec) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanup \(Maybe Handle
_maybeStdin, Maybe Handle
maybeStdout, Maybe Handle
maybeStderr, ProcessHandle
processHandle) ->
    (Scope -> IO a) -> IO a
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
      Thread (Seq Text)
stdoutThread <- Scope -> IO (Seq Text) -> IO (Thread (Seq Text))
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Handle -> IO (Seq Text)
drainTextHandle (Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
maybeStdout))
      Thread (Seq Text)
stderrThread <- Scope -> IO (Seq Text) -> IO (Thread (Seq Text))
forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Handle -> IO (Seq Text)
drainTextHandle (Maybe Handle -> Handle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
maybeStderr))
      ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle
      Seq Text
stdoutLines <- Thread (Seq Text) -> IO (Seq Text)
forall a. Thread a -> IO a
Ki.await Thread (Seq Text)
stdoutThread
      Seq Text
stderrLines <- Thread (Seq Text) -> IO (Seq Text)
forall a. Thread a -> IO a
Ki.await Thread (Seq Text)
stderrThread
      [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()
debugPrintGit [Text]
args Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode
      Seq Text -> Seq Text -> ExitCode -> IO a
forall a.
ProcessOutput a =>
Seq Text -> Seq Text -> ExitCode -> IO a
fromProcessOutput Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode
  where
    cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
    cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanup (Maybe Handle
maybeStdin, Maybe Handle
maybeStdout, Maybe Handle
maybeStderr, ProcessHandle
process) =
      IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void @_ @ExitCode IO ExitCode
terminate IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
closeHandles
      where
        closeHandles :: IO ()
        closeHandles :: IO ()
closeHandles =
          Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStdin Handle -> IO ()
hClose
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStdout Handle -> IO ()
hClose
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStderr Handle -> IO ()
hClose
        terminate :: IO ExitCode
        terminate :: IO ExitCode
terminate = do
          ProcessHandle -> (ProcessHandle__ -> IO ()) -> IO ()
forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle ProcessHandle
process \case
            ClosedHandle ExitCode
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            OpenExtHandle {} -> Text -> IO ()
forall a. Text -> a
bug Text
"OpenExtHandle is Windows-only"
            OpenHandle PHANDLE
pid -> do
              PHANDLE
pgid <- PHANDLE -> IO PHANDLE
getProcessGroupIDOf PHANDLE
pid
              Signal -> PHANDLE -> IO ()
signalProcessGroup Signal
sigTERM PHANDLE
pgid
          ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process

git_ :: [Text] -> IO ()
git_ :: [Text] -> IO ()
git_ =
  [Text] -> IO ()
forall a. ProcessOutput a => [Text] -> IO a
git

-- Yucky interactive/inherity variant (so 'git commit' can open an editor).
git2 :: [Text] -> IO ExitCode
git2 :: [Text] -> IO ExitCode
git2 [Text]
args = do
  (Maybe Handle
Nothing, Maybe Handle
Nothing, Just Handle
stderrHandle, ProcessHandle
processHandle) <-
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
      CreateProcess :: CmdSpec
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe GroupID
-> Maybe UserID
-> Bool
-> CreateProcess
CreateProcess
        { child_group :: Maybe GroupID
child_group = Maybe GroupID
forall a. Maybe a
Nothing,
          child_user :: Maybe UserID
child_user = Maybe UserID
forall a. Maybe a
Nothing,
          close_fds :: Bool
close_fds = Bool
True,
          cmdspec :: CmdSpec
cmdspec = String -> [String] -> CmdSpec
RawCommand String
"git" ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack [Text]
args),
          create_group :: Bool
create_group = Bool
False,
          cwd :: Maybe String
cwd = Maybe String
forall a. Maybe a
Nothing,
          delegate_ctlc :: Bool
delegate_ctlc = Bool
True,
          env :: Maybe [(String, String)]
env = Maybe [(String, String)]
forall a. Maybe a
Nothing,
          new_session :: Bool
new_session = Bool
False,
          std_err :: StdStream
std_err = StdStream
CreatePipe,
          std_in :: StdStream
std_in = StdStream
Inherit,
          std_out :: StdStream
std_out = StdStream
Inherit,
          -- windows-only
          create_new_console :: Bool
create_new_console = Bool
False,
          detach_console :: Bool
detach_console = Bool
False,
          use_process_jobs :: Bool
use_process_jobs = Bool
False
        }
  ExitCode
exitCode <-
    ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle IO ExitCode -> (AsyncException -> IO ExitCode) -> IO ExitCode
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \case
      AsyncException
UserInterrupt -> ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ExitCode
ExitFailure (-Int
130))
      AsyncException
exception -> AsyncException -> IO ExitCode
forall e a. Exception e => e -> IO a
throwIO AsyncException
exception
  Seq Text
stderrLines <- Handle -> IO (Seq Text)
drainTextHandle Handle
stderrHandle
  [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()
debugPrintGit [Text]
args Seq Text
forall a. Seq a
Seq.empty Seq Text
stderrLines ExitCode
exitCode
  ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitCode

debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()
debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()
debugPrintGit [Text]
args Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug do
    [Text] -> IO ()
putLines do
      let output :: [Text]
          output :: [Text]
output =
            (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
Text.brightBlack (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (Seq Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList @Seq (Seq Text
stdoutLines Seq Text -> Seq Text -> Seq Text
forall a. Semigroup a => a -> a -> a
<> Seq Text
stderrLines))
      Text -> Text
Text.bold (Text -> Text
Text.brightBlack ([Text] -> Text
Text.unwords (Text
marker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" git" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
quoteText [Text]
args))) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
output
  where
    marker :: Text
    marker :: Text
marker =
      case ExitCode
exitCode of
        ExitFailure Int
_ -> Text
"✗"
        ExitCode
ExitSuccess -> Text
"✓"

drainTextHandle :: Handle -> IO (Seq Text)
drainTextHandle :: Handle -> IO (Seq Text)
drainTextHandle Handle
handle = do
  let loop :: Seq Text -> IO (Seq Text)
loop Seq Text
acc =
        Handle -> IO Bool
hIsEOF Handle
handle IO Bool -> (Bool -> IO (Seq Text)) -> IO (Seq Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
False -> do
            Text
line <- Handle -> IO Text
Text.hGetLine Handle
handle
            Seq Text -> IO (Seq Text)
loop (Seq Text -> IO (Seq Text)) -> Seq Text -> IO (Seq Text)
forall a b. (a -> b) -> a -> b
$! Seq Text
acc Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
Seq.|> Text
line
          Bool
True -> Seq Text -> IO (Seq Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Text
acc
  Seq Text -> IO (Seq Text)
loop Seq Text
forall a. Seq a
Seq.empty