{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}

module Mit.Git where

import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.ANSI as Text
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.Unsafe (unsafePerformIO)
import System.Posix.Terminal (queryTerminal)
import System.Process

-- FIXME this finds the wrong dir for worktrees
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 #-}

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 [GitCommitInfo]
gitCommitsBetween :: Maybe Text -> Text -> IO [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 [GitCommitInfo] -> IO [GitCommitInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else do
      [Text]
commits <-
        -- --first-parent seems desirable for topic branches
        [Text] -> IO [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=10",
            (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
          ]
      [GitCommitInfo] -> IO [GitCommitInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text -> GitCommitInfo) -> [Text] -> [GitCommitInfo]
forall a b. (a -> b) -> [a] -> [b]
map Text -> GitCommitInfo
parseCommitInfo ([Text] -> [Text]
forall a. [a] -> [a]
dropEvens [Text]
commits))
  where
    -- git rev-list with a custom format prefixes every commit with a redundant line :|
    dropEvens :: [a] -> [a]
    dropEvens :: [a] -> [a]
dropEvens = \case
      a
_ : a
x : [a]
xs -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. [a] -> [a]
dropEvens [a]
xs
      [a]
xs -> [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
  (Maybe Handle
Nothing, Just Handle
stdoutHandle, 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
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
        }
  ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle
  [Text]
stdoutLines <- Handle -> IO [Text]
drainTextHandle Handle
stdoutHandle
  [Text]
stderrLines <- Handle -> IO [Text]
drainTextHandle Handle
stderrHandle
  [Text] -> [Text] -> [Text] -> ExitCode -> IO ()
debugPrintGit [Text]
args [Text]
stdoutLines [Text]
stderrLines ExitCode
exitCode
  [Text] -> [Text] -> ExitCode -> IO a
forall a. ProcessOutput a => [Text] -> [Text] -> ExitCode -> IO a
fromProcessOutput [Text]
stdoutLines [Text]
stderrLines ExitCode
exitCode

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
  [Text]
stderrLines <- Handle -> IO [Text]
drainTextHandle Handle
stderrHandle
  [Text] -> [Text] -> [Text] -> ExitCode -> IO ()
debugPrintGit [Text]
args [] [Text]
stderrLines ExitCode
exitCode
  ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitCode

debugPrintGit :: [Text] -> [Text] -> [Text] -> ExitCode -> IO ()
debugPrintGit :: [Text] -> [Text] -> [Text] -> ExitCode -> IO ()
debugPrintGit [Text]
args [Text]
stdoutLines [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
<>)) ([Text]
stdoutLines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [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
"✓"