-- | High-level git operations
module Mit.Git
  ( DiffResult (..),
    GitCommitInfo,
    prettyGitCommitInfo,
    GitConflict,
    showGitConflict,
    GitVersion (..),
    showGitVersion,
    git,
    git_,
    gitApplyStash,
    gitBranch,
    gitBranchHead,
    gitBranchWorktreeDir,
    gitCommit,
    gitCommitsBetween,
    gitConflicts,
    gitConflictsWith,
    gitCreateStash,
    gitDiff,
    gitExistCommitsBetween,
    gitExistUntrackedFiles,
    gitFetch,
    gitFetch_,
    gitHead,
    gitIsMergeCommit,
    gitMaybeHead,
    gitMergeInProgress,
    gitPush,
    gitRemoteBranchExists,
    gitRemoteBranchHead,
    gitRevParseAbsoluteGitDir,
    gitRevParseShowToplevel,
    gitUnstageChanges,
    gitVersion,
    -- unused, but useful? not sure
    gitDefaultBranch,
    gitShow,
    parseGitRepo,
  )
where

import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Sequence qualified as Seq
import Data.Text qualified as Text
import Data.Text.Builder.ANSI qualified as Text.Builder
import Data.Text.IO qualified as Text
import Data.Text.Lazy.Builder qualified as Text (Builder)
import Data.Text.Lazy.Builder qualified as Text.Builder
import Ki qualified
import Mit.Builder qualified as Builder
import Mit.Env (Env (..))
import Mit.GitCommand qualified as Git
import Mit.Monad
import Mit.Prelude
import Mit.Process
import Mit.Stanza
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
import Text.Parsec qualified as Parsec

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

parseGitCommitInfo :: Text -> GitCommitInfo
parseGitCommitInfo :: Text -> GitCommitInfo
parseGitCommitInfo Text
line =
  case (Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
== Char
'\xFEFF') Text
line of
    [Text
author, Text
date, Text
hash, Text
shorthash, Text
subject] -> 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]
_ -> forall a. HasCallStack => String -> a
error (Text -> String
Text.unpack Text
line)

prettyGitCommitInfo :: GitCommitInfo -> Text.Builder
prettyGitCommitInfo :: GitCommitInfo -> Builder
prettyGitCommitInfo GitCommitInfo
info =
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ Builder -> Builder
Text.Builder.bold (Builder -> Builder
Text.Builder.black (Text -> Builder
Text.Builder.fromText GitCommitInfo
info.shorthash)),
      Builder
Builder.space,
      Builder -> Builder
Text.Builder.bold (Builder -> Builder
Text.Builder.white (Text -> Builder
Text.Builder.fromText GitCommitInfo
info.subject)),
      Builder
" - ",
      Builder -> Builder
Text.Builder.italic (Builder -> Builder
Text.Builder.white (Text -> Builder
Text.Builder.fromText GitCommitInfo
info.author)),
      Builder
Builder.space,
      Builder -> Builder
Text.Builder.italic (Builder -> Builder
Text.Builder.yellow (Text -> Builder
Text.Builder.fromText GitCommitInfo
info.date))
    ]

-- FIXME some other color, magenta?

data GitConflict
  = GitConflict GitConflictXY Text
  deriving stock (GitConflict -> GitConflict -> Bool
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
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)

-- FIXME
--
-- error: The following untracked working tree files would be overwritten by merge:
--         administration-client/administration-client.cabal
--         aeson-simspace/aeson-simspace.cabal
--         attack-designer/api/attack-designer-api.cabal
--         attack-designer/db/attack-designer-db.cabal
--         attack-designer/server/attack-designer-server.cabal
--         attack-integrations/attack-integrations.cabal
--         authz/simspace-authz.cabal
--         caching/caching.cabal
--         common-testlib/common-testlib.cabal
--         db-infra/db-infra.cabal
--         db-infra/migrations/0_migrate-rich-text-images-to-minio/migrate-rich-text-images-to-minio.cabal
--         db-infra/migrations/2.0.0.1010_migrate-questions-into-content-modules/range-data-server-migrate-questions-into-content-modules.cabal
--         db-infra/migrations/2.0.0.19_migrate-hello-table/range-data-server-migrate-hello-table.cabal
--         db-infra/migrations/2.0.0.21_migrate-puppet-yaml-to-text/range-data-server-migrate-puppet-yaml-to-text.cabal
--         db-infra/migrations/2.0.0.9015_migrate-refresh-stocks/range-data-server-migrate-refresh-stocks.cabal
--         db-infra/migrations/shared/range-data-server-migration.cabal
-- Please move or remove them before you merge.
-- Aborting
parseGitConflict :: Text -> Maybe GitConflict
parseGitConflict :: Text -> Maybe GitConflict
parseGitConflict Text
line = do
  [Text
xy, Text
name] <- forall a. a -> Maybe a
Just (Text -> [Text]
Text.words Text
line)
  GitConflictXY -> Text -> GitConflict
GitConflict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe GitConflictXY
parseGitConflictXY Text
xy forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> Maybe a
Just Text
name

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

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
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
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" -> forall a. a -> Maybe a
Just GitConflictXY
AA
  Text
"AU" -> forall a. a -> Maybe a
Just GitConflictXY
AU
  Text
"DD" -> forall a. a -> Maybe a
Just GitConflictXY
DD
  Text
"DU" -> forall a. a -> Maybe a
Just GitConflictXY
DU
  Text
"UA" -> forall a. a -> Maybe a
Just GitConflictXY
UA
  Text
"UD" -> forall a. a -> Maybe a
Just GitConflictXY
UD
  Text
"UU" -> forall a. a -> Maybe a
Just GitConflictXY
UU
  Text
_ -> forall a. Maybe a
Nothing

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

data GitVersion
  = GitVersion Int Int Int
  deriving stock (GitVersion -> GitVersion -> Bool
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
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
Ord)

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

-- | Apply stash, return conflicts.
gitApplyStash :: Text -> Mit Env x [GitConflict]
gitApplyStash :: forall x. Text -> Mit Env x [GitConflict]
gitApplyStash Text
stash = do
  [GitConflict]
conflicts <-
    forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> Text -> Command
Git.StashApply FlagQuiet
Git.FlagQuiet Text
stash) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall x. Mit Env x [GitConflict]
gitConflicts
      Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  forall x. Mit Env x ()
gitUnstageChanges
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [GitConflict]
conflicts

-- | Create a branch.
-- FIXME inline this
gitBranch :: Text -> Mit Env x ()
gitBranch :: forall x. Text -> Mit Env x ()
gitBranch Text
branch =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagNoTrack -> Text -> Command
Git.Branch FlagNoTrack
Git.FlagNoTrack Text
branch)

-- | Get the head of a local branch (refs/heads/...).
gitBranchHead :: Text -> Mit Env x (Maybe Text)
gitBranchHead :: forall x. Text -> Mit Env x (Maybe Text)
gitBranchHead Text
branch =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> FlagVerify -> Text -> Command
Git.RevParse FlagQuiet
Git.NoFlagQuiet FlagVerify
Git.NoFlagVerify (Text
"refs/heads/" forall a. Semigroup a => a -> a -> a
<> Text
branch)) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left ExitCode
_ -> forall a. Maybe a
Nothing
    Right Text
head -> forall a. a -> Maybe a
Just Text
head

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

gitCommit :: Mit Env x Bool
gitCommit :: forall x. Mit Env x Bool
gitCommit =
  forall a r x. IO a -> Mit r x a
io (Fd -> IO Bool
queryTerminal Fd
0) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> do
      Maybe String
message <- forall a r x. IO a -> Mit r x a
io (String -> IO (Maybe String)
lookupEnv String
"MIT_COMMIT_MESSAGE")
      forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text
"commit", Text
"--all", Text
"--message", forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" String -> Text
Text.pack Maybe String
message]
    Bool
True ->
      forall x. [Text] -> Mit Env x ExitCode
git2 [Text
"commit", Text
"--patch", Text
"--quiet"] 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 -> Mit Env x (Seq GitCommitInfo)
gitCommitsBetween :: forall x. Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo)
gitCommitsBetween Maybe Text
commit1 Text
commit2 =
  if Maybe Text
commit1 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
commit2
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Seq a
Seq.empty
    else do
      Seq Text
commits <-
        -- --first-parent seems desirable for topic branches
        forall a x. ProcessOutput a => [Text] -> Mit Env x 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",
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Text
c1 Text
c2 -> Text
c1 forall a. Semigroup a => a -> a -> a
<> Text
".." forall a. Semigroup a => a -> a -> a
<> Text
c2) Maybe Text
commit1 Text
commit2
          ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GitCommitInfo
parseGitCommitInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall a. Seq a -> Seq a
dropEvens = \case
      a
_ Seq.:<| a
x Seq.:<| Seq a
xs -> a
x forall a. a -> Seq a -> Seq a
Seq.<| forall a. Seq a -> Seq a
dropEvens Seq a
xs
      Seq a
xs -> Seq a
xs

gitConflicts :: Mit Env x [GitConflict]
gitConflicts :: forall x. Mit Env x [GitConflict]
gitConflicts =
  forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe GitConflict
parseGitConflict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagNoRenames -> Command
Git.StatusV1 FlagNoRenames
Git.FlagNoRenames)

-- | Get the conflicts with the given commitish.
--
-- Precondition: there is no merge in progress.
gitConflictsWith :: Text -> Mit Env x [GitConflict]
gitConflictsWith :: forall x. Text -> Mit Env x [GitConflict]
gitConflictsWith Text
commit = do
  Maybe Text
maybeStash <- forall x. Mit Env x (Maybe Text)
gitStash
  [GitConflict]
conflicts <- do
    forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagNoCommit -> FlagNoFF -> Text -> Command
Git.Merge FlagNoCommit
Git.FlagNoCommit FlagNoFF
Git.FlagNoFF Text
commit) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> forall x. Mit Env x [GitConflict]
gitConflicts
      Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall x. Mit Env x Bool
gitMergeInProgress (forall x. Command -> Mit Env x ()
Git.git_ Command
Git.MergeAbort)
  forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Text
maybeStash \Text
stash -> forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> Text -> Command
Git.StashApply FlagQuiet
Git.FlagQuiet Text
stash)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [GitConflict]
conflicts

-- | Precondition: there are changes to stash
gitCreateStash :: Mit Env x Text
gitCreateStash :: forall x. Mit Env x Text
gitCreateStash = do
  forall x. Command -> Mit Env x ()
Git.git_ Command
Git.AddAll -- it seems certain things (like renames), unless staged, cannot be stashed
  Text
stash <- forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git Command
Git.StashCreate
  forall x. Mit Env x ()
gitUnstageChanges
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
stash

gitDefaultBranch :: Text -> Mit Env x Text
gitDefaultBranch :: forall x. Text -> Mit Env x Text
gitDefaultBranch Text
remote = do
  Text
ref <- forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (Text -> Command
Git.SymbolicRef (Text
"refs/remotes/" forall a. Semigroup a => a -> a -> a
<> Text
remote forall a. Semigroup a => a -> a -> a
<> Text
"/HEAD"))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Text -> Text
Text.drop (Int
14 forall a. Num a => a -> a -> a
+ Text -> Int
Text.length Text
remote) Text
ref)

-- FIXME document this
gitDiff :: Mit Env x DiffResult
gitDiff :: forall x. Mit Env x DiffResult
gitDiff = do
  forall x. Mit Env x ()
gitUnstageChanges
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> Command
Git.Diff FlagQuiet
Git.FlagQuiet) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Bool
False -> DiffResult
Differences
    Bool
True -> DiffResult
NoDifferences

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

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

gitFetch :: Text -> Mit Env x Bool
gitFetch :: forall x. Text -> Mit Env x Bool
gitFetch Text
remote = do
  Map Text Bool
fetched <- forall a r x. IO a -> Mit r x a
io (forall a. IORef a -> IO a
readIORef IORef (Map Text Bool)
fetchedRef)
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
remote Map Text Bool
fetched of
    Maybe Bool
Nothing -> do
      Bool
success <- forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (Text -> Command
Git.Fetch Text
remote)
      forall a r x. IO a -> Mit r x a
io (forall a. IORef a -> a -> IO ()
writeIORef IORef (Map Text Bool)
fetchedRef (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
remote Bool
success Map Text Bool
fetched))
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
success
    Just Bool
success -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
success

-- Only fetch each remote at most once per run of `mit`
fetchedRef :: IORef (Map Text Bool)
fetchedRef :: IORef (Map Text Bool)
fetchedRef =
  forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty)
{-# NOINLINE fetchedRef #-}

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

-- | Get the head commit.
gitHead :: Mit Env x Text
gitHead :: forall x. Mit Env x Text
gitHead =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> FlagVerify -> Text -> Command
Git.RevParse FlagQuiet
Git.NoFlagQuiet FlagVerify
Git.NoFlagVerify Text
"HEAD")

gitIsMergeCommit :: Text -> Mit Env x Bool
gitIsMergeCommit :: forall x. Text -> Mit Env x Bool
gitIsMergeCommit Text
commit =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> FlagVerify -> Text -> Command
Git.RevParse FlagQuiet
Git.FlagQuiet FlagVerify
Git.FlagVerify (Text
commit forall a. Semigroup a => a -> a -> a
<> Text
"^2"))

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

-- | Get the head commit, if it exists.
gitMaybeHead :: Mit Env x (Maybe Text)
gitMaybeHead :: forall x. Mit Env x (Maybe Text)
gitMaybeHead =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> FlagVerify -> Text -> Command
Git.RevParse FlagQuiet
Git.NoFlagQuiet FlagVerify
Git.NoFlagVerify Text
"HEAD") forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left ExitCode
_ -> forall a. Maybe a
Nothing
    Right Text
commit -> forall a. a -> Maybe a
Just Text
commit

gitMergeInProgress :: Mit Env x Bool
gitMergeInProgress :: forall x. Mit Env x Bool
gitMergeInProgress = do
  Env
env <- forall r x. Mit r x r
getEnv
  forall a r x. IO a -> Mit r x a
io (String -> IO Bool
doesFileExist (Text -> String
Text.unpack (Env
env.gitdir forall a. Semigroup a => a -> a -> a
<> Text
"/MERGE_HEAD")))

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

-- | Does the given remote branch (refs/remotes/...) exist?
gitRemoteBranchExists :: Text -> Text -> Mit Env x Bool
gitRemoteBranchExists :: forall x. Text -> Text -> Mit Env x Bool
gitRemoteBranchExists Text
remote Text
branch =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> FlagVerify -> Text -> Command
Git.RevParse FlagQuiet
Git.FlagQuiet FlagVerify
Git.FlagVerify (Text
"refs/remotes/" forall a. Semigroup a => a -> a -> a
<> Text
remote forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
branch))

-- | Get the head of a remote branch.
gitRemoteBranchHead :: Text -> Text -> Mit Env x (Maybe Text)
gitRemoteBranchHead :: forall x. Text -> Text -> Mit Env x (Maybe Text)
gitRemoteBranchHead Text
remote Text
branch =
  forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (FlagQuiet -> FlagVerify -> Text -> Command
Git.RevParse FlagQuiet
Git.NoFlagQuiet FlagVerify
Git.NoFlagVerify (Text
"refs/remotes/" forall a. Semigroup a => a -> a -> a
<> Text
remote forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
branch)) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left ExitCode
_ -> forall a. Maybe a
Nothing
    Right Text
head -> forall a. a -> Maybe a
Just Text
head

gitRevParseAbsoluteGitDir :: Mit Env x (Maybe Text)
gitRevParseAbsoluteGitDir :: forall x. Mit Env x (Maybe Text)
gitRevParseAbsoluteGitDir =
  forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text
"rev-parse", Text
"--absolute-git-dir"] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left ExitCode
_ -> forall a. Maybe a
Nothing
    Right Text
dir -> forall a. a -> Maybe a
Just Text
dir

-- | The root of this git worktree.
gitRevParseShowToplevel :: Mit Env x Text
gitRevParseShowToplevel :: forall x. Mit Env x Text
gitRevParseShowToplevel =
  forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text
"rev-parse", Text
"--show-toplevel"]

gitShow :: Text -> Mit Env x GitCommitInfo
gitShow :: forall x. Text -> Mit Env x GitCommitInfo
gitShow Text
commit =
  Text -> GitCommitInfo
parseGitCommitInfo
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a x. ProcessOutput a => [Text] -> Mit Env x a
git
      [ Text
"show",
        Text
"--color=always",
        Text
"--date=human",
        Text
"--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s",
        Text
commit
      ]

-- | Stash uncommitted changes (if any).
gitStash :: Mit Env x (Maybe Text)
gitStash :: forall x. Mit Env x (Maybe Text)
gitStash = do
  forall x. Mit Env x DiffResult
gitDiff forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DiffResult
Differences -> do
      Text
stash <- forall x. Mit Env x Text
gitCreateStash
      forall x. Command -> Mit Env x ()
Git.git_ (FlagD -> FlagForce -> Command
Git.Clean FlagD
Git.FlagD FlagForce
Git.FlagForce)
      forall x. Command -> Mit Env x ()
Git.git_ (ResetMode -> FlagQuiet -> Text -> Command
Git.Reset ResetMode
Git.Hard FlagQuiet
Git.FlagQuiet Text
"HEAD")
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Text
stash)
    DiffResult
NoDifferences -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

gitUnstageChanges :: Mit Env x ()
gitUnstageChanges :: forall x. Mit Env x ()
gitUnstageChanges = do
  forall x. Command -> Mit Env x ()
Git.git_ (FlagQuiet -> [Text] -> Command
Git.ResetPaths FlagQuiet
Git.FlagQuiet [Text
"."])
  [Text]
untrackedFiles <- forall x. Mit Env x [Text]
gitListUntrackedFiles
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
untrackedFiles) (forall x. Command -> Mit Env x ()
Git.git_ (FlagIntentToAdd -> [Text] -> Command
Git.Add FlagIntentToAdd
Git.FlagIntentToAdd [Text]
untrackedFiles))

gitVersion :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x GitVersion
gitVersion :: forall x.
(forall void. [Stanza] -> Mit Env x void) -> Mit Env x GitVersion
gitVersion forall void. [Stanza] -> Mit Env x void
return = do
  Text
v0 <- forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text
"--version"]
  forall a. a -> Maybe a -> a
fromMaybe (forall void. [Stanza] -> Mit Env x void
return [forall a. a -> Maybe a
Just (Builder
"Could not parse git version from: " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.fromText Text
v0)]) do
    Text
"git" : Text
"version" : Text
v1 : [Text]
_ <- forall a. a -> Maybe a
Just (Text -> [Text]
Text.words Text
v0)
    [Text
sx, Text
sy, Text
sz] <- forall a. a -> Maybe a
Just ((Char -> Bool) -> Text -> [Text]
Text.split (forall a. Eq a => a -> a -> Bool
== Char
'.') Text
v1)
    Int
x <- forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
sx)
    Int
y <- forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
sy)
    Int
z <- forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
sz)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (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,
    GitWorktree -> Bool
prunable :: Bool
  }

-- /dir/one 0efd393c35 [oingo]         -> ("/dir/one", "0efd393c35", Just "oingo")
-- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing)
gitWorktreeList :: Mit Env x [GitWorktree]
gitWorktreeList :: forall x. Mit Env x [GitWorktree]
gitWorktreeList = do
  forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text
"worktree", Text
"list"] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. (a -> b) -> [a] -> [b]
map \Text
line ->
    case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
Parsec.parse Parsec Text () GitWorktree
parser String
"" Text
line of
      Left ParseError
err -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show ParseError
err)
      Right GitWorktree
worktree -> GitWorktree
worktree
  where
    parser :: Parsec.Parsec Text () GitWorktree
    parser :: Parsec Text () GitWorktree
parser = do
      Text
directory <- Parsec Text () Text
segmentP
      forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
Parsec.spaces
      Text
commit <- Parsec Text () Text
segmentP
      forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
Parsec.spaces
      Maybe Text
branch <-
        forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
Parsec.string String
"(detached HEAD)",
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just do
              Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
Parsec.char Char
'['
              String
branch <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
Parsec.manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.anyChar (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
Parsec.char Char
']')
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
Text.pack String
branch)
          ]
      forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
Parsec.spaces
      Bool
prunable <-
        forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
Parsec.string String
"prunable",
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure GitWorktree {Maybe Text
branch :: Maybe Text
$sel:branch:GitWorktree :: Maybe Text
branch, Text
commit :: Text
$sel:commit:GitWorktree :: Text
commit, Text
directory :: Text
$sel:directory:GitWorktree :: Text
directory, Bool
prunable :: Bool
$sel:prunable:GitWorktree :: Bool
prunable}
      where
        segmentP :: Parsec.Parsec Text () Text
        segmentP :: Parsec Text () Text
segmentP =
          String -> Text
Text.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
Parsec.many1 (forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
Parsec.satisfy (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace))

-- 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
url, (Char -> Bool) -> Text -> Text
Text.takeWhileEnd (forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
url')

git :: ProcessOutput a => [Text] -> Mit Env x a
git :: forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text]
args = do
  let spec :: CreateProcess
      spec :: CreateProcess
spec =
        CreateProcess
          { child_group :: Maybe GroupID
child_group = forall a. Maybe a
Nothing,
            child_user :: Maybe UserID
child_user = forall a. Maybe a
Nothing,
            close_fds :: Bool
close_fds = Bool
True,
            cmdspec :: CmdSpec
cmdspec = String -> [String] -> CmdSpec
RawCommand String
"git" (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 = forall a. Maybe a
Nothing,
            delegate_ctlc :: Bool
delegate_ctlc = Bool
False,
            env :: Maybe [(String, String)]
env = 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
          }
  forall a r x b.
(forall v. (a -> IO v) -> IO v)
-> (a -> Mit r (X x b) b) -> Mit r x b
with (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) -> do
    forall a r x b.
(forall v. (a -> IO v) -> IO v)
-> (a -> Mit r (X x b) b) -> Mit r x b
with forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
      Thread (Seq Text)
stdoutThread <- forall a r x. IO a -> Mit r x a
io (forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Handle -> IO (Seq Text)
drainTextHandle (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
maybeStdout)))
      Thread (Seq Text)
stderrThread <- forall a r x. IO a -> Mit r x a
io (forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Handle -> IO (Seq Text)
drainTextHandle (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
maybeStderr)))
      ExitCode
exitCode <- forall a r x. IO a -> Mit r x a
io (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle)
      Seq Text
stdoutLines <- forall a r x. IO a -> Mit r x a
io (forall a. STM a -> IO a
atomically (forall a. Thread a -> STM a
Ki.await Thread (Seq Text)
stdoutThread))
      Seq Text
stderrLines <- forall a r x. IO a -> Mit r x a
io (forall a. STM a -> IO a
atomically (forall a. Thread a -> STM a
Ki.await Thread (Seq Text)
stderrThread))
      forall x.
[Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit [Text]
args Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode
      forall a r x. IO a -> Mit r x a
io (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) =
      forall (f :: * -> *) a. Functor f => f a -> f ()
void @_ @ExitCode IO ExitCode
terminate forall a b. IO a -> IO b -> IO a
`finally` IO ()
closeHandles
      where
        closeHandles :: IO ()
        closeHandles :: IO ()
closeHandles =
          forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStdin Handle -> IO ()
hClose
            forall a b. IO a -> IO b -> IO a
`finally` forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStdout Handle -> IO ()
hClose
            forall a b. IO a -> IO b -> IO a
`finally` 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
          forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle ProcessHandle
process \case
            ClosedHandle ExitCode
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            OpenExtHandle {} -> 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] -> Mit Env x ()
git_ :: forall x. [Text] -> Mit Env x ()
git_ =
  forall a x. ProcessOutput a => [Text] -> Mit Env x a
git

-- Yucky interactive/inherity variant (so 'git commit' can open an editor).
--
-- FIXME bracket
git2 :: [Text] -> Mit Env x ExitCode
git2 :: forall x. [Text] -> Mit Env x ExitCode
git2 [Text]
args = do
  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
stderrHandle, ProcessHandle
processHandle) <-
    forall a r x. IO a -> Mit r x a
io do
      CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
        CreateProcess
          { child_group :: Maybe GroupID
child_group = forall a. Maybe a
Nothing,
            child_user :: Maybe UserID
child_user = forall a. Maybe a
Nothing,
            close_fds :: Bool
close_fds = Bool
True,
            cmdspec :: CmdSpec
cmdspec = String -> [String] -> CmdSpec
RawCommand String
"git" (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 = forall a. Maybe a
Nothing,
            delegate_ctlc :: Bool
delegate_ctlc = Bool
True,
            env :: Maybe [(String, String)]
env = 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 <-
    forall a r x. IO a -> Mit r x a
io do
      ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \case
        AsyncException
UserInterrupt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ExitCode
ExitFailure (-Int
130))
        AsyncException
exception -> forall e a. Exception e => e -> IO a
throwIO AsyncException
exception
  Seq Text
stderrLines <- forall a r x. IO a -> Mit r x a
io (Handle -> IO (Seq Text)
drainTextHandle (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
stderrHandle))
  forall x.
[Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit [Text]
args forall a. Seq a
Seq.empty Seq Text
stderrLines ExitCode
exitCode
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitCode

debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit :: forall x.
[Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit [Text]
args Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode = do
  Env
env <- forall r x. Mit r x r
getEnv
  forall a r x. IO a -> Mit r x a
io case Env
env.verbosity of
    Int
1 -> Builder -> IO ()
Builder.putln (Builder -> Builder
Text.Builder.brightBlack Builder
v1)
    Int
2 -> Builder -> IO ()
Builder.putln (Builder -> Builder
Text.Builder.brightBlack (Builder
v1 forall a. Semigroup a => a -> a -> a
<> Builder
v2))
    Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    v1 :: Builder
v1 = Builder -> Builder
Text.Builder.bold (Builder
marker forall a. Semigroup a => a -> a -> a
<> Builder
" git " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *). Foldable f => f Builder -> Builder
Builder.hcat (forall a b. (a -> b) -> [a] -> [b]
map Text -> Builder
quote [Text]
args))
    v2 :: Builder
v2 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Text
line -> Builder
"\n    " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.fromText Text
line) (Seq Text
stdoutLines forall a. Semigroup a => a -> a -> a
<> Seq Text
stderrLines)

    quote :: Text -> Text.Builder
    quote :: Text -> Builder
quote Text
s =
      if (Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
isSpace Text
s
        then Builder -> Builder
Builder.squoted (Text -> Builder
Text.Builder.fromText (HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"'" Text
"\\'" Text
s))
        else Text -> Builder
Text.Builder.fromText Text
s

    marker :: Text.Builder
    marker :: Builder
marker =
      case ExitCode
exitCode of
        ExitFailure Int
_ -> Char -> Builder
Text.Builder.singleton Char
'✗'
        ExitCode
ExitSuccess -> Char -> Builder
Text.Builder.singleton Char
'✓'

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 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 forall a b. (a -> b) -> a -> b
$! Seq Text
acc forall a. Seq a -> a -> Seq a
Seq.|> Text
line
          Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Text
acc
  Seq Text -> IO (Seq Text)
loop forall a. Seq a
Seq.empty