{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}

module Mit where

import qualified Data.List.NonEmpty as List1
import qualified Data.Text as Text
import qualified Data.Text.ANSI as Text
import qualified Data.Text.Encoding.Base64 as Text
import qualified Data.Text.IO as Text
import Mit.Git
import Mit.Prelude
import qualified System.Clock as Clock
import System.Directory (doesDirectoryExist, removeFile, withCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (ExitCode (..), exitFailure)

-- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit
-- ephemeral feeling
-- FIXME bail if active cherry-pick, active revert, active rebase, what else?
-- FIXME rev-list max 11, use ellipses after 10
-- FIXME test file deleted by us/them conflict

-- TODO mit init
-- TODO mit delete-branch
-- TODO tweak things to work with git < 2.30.1
-- TODO rewrite mit commit algorithm in readme
-- TODO git(hub,lab) flow or something?
-- TODO 'mit branch' with dirty working directory - apply changes to new worktree?
-- TODO undo in more cases?
-- TODO recommend merging master if it conflicts
-- TODO mit log
-- TODO optparse-applicative

main :: IO ()
main :: IO ()
main = do
  IO [String]
getArgs IO [String] -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [String
"branch", String
branch] -> Text -> IO ()
mitBranch (String -> Text
Text.pack String
branch)
    [String
"clone", Text -> Maybe (Text, Text)
parseGitRepo (Text -> Maybe (Text, Text))
-> (String -> Text) -> String -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack -> Just (Text
url, Text
name)] -> Text -> Text -> IO ()
mitClone Text
url Text
name
    [String
"commit"] -> IO ()
mitCommit
    [String
"merge", String
branch] -> Text -> IO ()
mitMerge (String -> Text
Text.pack String
branch)
    [String
"sync"] -> IO ()
mitSync
    [String
"undo"] -> IO ()
mitUndo
    [String]
_ -> do
      [Text] -> IO ()
putLines
        [ Text
"Usage:",
          Text
"  mit branch ≪branch≫",
          Text
"  mit clone ≪repo≫",
          Text
"  mit commit",
          Text
"  mit merge ≪branch≫",
          Text
"  mit sync",
          Text
"  mit undo"
        ]
      IO ()
forall a. IO a
exitFailure

dieIfBuggyGit :: IO ()
dieIfBuggyGit :: IO ()
dieIfBuggyGit = do
  GitVersion
version <- IO GitVersion
gitVersion
  case ((GitVersion, Text)
 -> [(GitVersion, Text)] -> [(GitVersion, Text)])
-> [(GitVersion, Text)]
-> [(GitVersion, Text)]
-> [(GitVersion, Text)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(GitVersion
ver, Text
err) [(GitVersion, Text)]
acc -> if GitVersion
version GitVersion -> GitVersion -> Bool
forall a. Ord a => a -> a -> Bool
< GitVersion
ver then (GitVersion
ver, Text
err) (GitVersion, Text) -> [(GitVersion, Text)] -> [(GitVersion, Text)]
forall a. a -> [a] -> [a]
: [(GitVersion, Text)]
acc else [(GitVersion, Text)]
acc) [] [(GitVersion, Text)]
validations of
    [] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [(GitVersion, Text)]
errors ->
      [Text] -> IO ()
forall a. [Text] -> IO a
die ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$
        ((GitVersion, Text) -> Text) -> [(GitVersion, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
          (\(GitVersion
ver, Text
err) -> Text
"Prior to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
"git" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitVersion -> Text
showGitVersion GitVersion
ver Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err)
          [(GitVersion, Text)]
errors
  where
    validations :: [(GitVersion, Text)]
    validations :: [(GitVersion, Text)]
validations =
      [ ( Int -> Int -> Int -> GitVersion
GitVersion Int
2 Int
29 Int
0,
          Text -> Text
Text.bold Text
"git commit --patch"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was broken for new files added with "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
"git add --intent-to-add"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        ),
        ( Int -> Int -> Int -> GitVersion
GitVersion Int
2 Int
30 Int
1,
          Text -> Text
Text.bold Text
"git stash create"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was broken for new files added with "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
"git add --intent-to-add"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        )
      ]

dieIfMergeInProgress :: IO ()
dieIfMergeInProgress :: IO ()
dieIfMergeInProgress =
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitMergeInProgress ([Text] -> IO ()
forall a. [Text] -> IO a
die [Text -> Text
Text.bold Text
"git merge" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in progress."])

dieIfNotInGitDir :: IO ()
dieIfNotInGitDir :: IO ()
dieIfNotInGitDir =
  IO Text -> IO (Either ExitCode Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (Text -> IO Text
forall a. a -> IO a
evaluate Text
gitdir) IO (Either ExitCode Text)
-> (Either ExitCode Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (ExitCode
_ :: ExitCode) -> IO ()
forall a. IO a
exitFailure
    Right Text
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

die :: [Text] -> IO a
die :: [Text] -> IO a
die [Text]
ss = do
  Text -> IO ()
Text.putStr (Text -> Text
Text.red ([Text] -> Text
Text.unlines [Text]
ss))
  IO a
forall a. IO a
exitFailure

mitBranch :: Text -> IO ()
mitBranch :: Text -> IO ()
mitBranch Text
branch = do
  IO ()
dieIfNotInGitDir

  Text -> IO (Maybe Text)
gitBranchWorktreeDir Text
branch IO (Maybe Text) -> (Maybe Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Text
Nothing ->
      String -> IO Bool
doesDirectoryExist (Text -> String
Text.unpack Text
worktreeDir) IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> do
          [Text] -> IO ()
git_ [Text
"worktree", Text
"add", Text
"--detach", Text
worktreeDir]
          String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory (Text -> String
Text.unpack Text
worktreeDir) do
            Text -> IO Bool
gitBranchExists Text
branch IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
False -> do
                Text -> IO ()
gitBranch Text
branch
                Text -> IO ()
gitSwitch Text
branch
                Text -> IO ()
gitFetch_ Text
"origin"
                IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Text -> Text -> IO Bool
gitRemoteBranchExists Text
"origin" Text
branch) do
                  let upstream :: Text
upstream = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
                  [Text] -> IO ()
git_ [Text
"reset", Text
"--hard", Text
upstream]
                  [Text] -> IO ()
git_ [Text
"branch", Text
"--set-upstream-to", Text
upstream]
              Bool
True -> Text -> IO ()
gitSwitch Text
branch
        Bool
True -> [Text] -> IO ()
forall a. [Text] -> IO a
die [Text
"Directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
worktreeDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already exists."]
    Just Text
directory ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
directory Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
worktreeDir) do
        [Text] -> IO ()
forall a. [Text] -> IO a
die [Text -> Text
Text.bold Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is already checked out in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
directory Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."]
  where
    worktreeDir :: Text
    worktreeDir :: Text
worktreeDir =
      (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
gitdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch

mitClone :: Text -> Text -> IO ()
mitClone :: Text -> Text -> IO ()
mitClone Text
url Text
name =
  -- FIXME use 'git config --get init.defaultBranch'
  [Text] -> IO ()
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"clone", Text
url, Text
"--separate-git-dir", Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/.git", Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/master"]

mitCommit :: IO ()
mitCommit :: IO ()
mitCommit = do
  IO ()
dieIfNotInGitDir
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitExistUntrackedFiles IO ()
dieIfBuggyGit
  IO DiffResult
gitDiff IO DiffResult -> (DiffResult -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DiffResult
Differences ->
      IO Bool
gitMergeInProgress IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> IO ()
mitCommit_
        Bool
True -> IO ()
mitCommitMerge
    DiffResult
NoDifferences -> IO ()
forall a. IO a
exitFailure

mitCommit_ :: IO ()
mitCommit_ :: IO ()
mitCommit_ = do
  Bool
fetched <- Text -> IO Bool
gitFetch Text
"origin"
  Text
branch <- IO Text
gitCurrentBranch
  let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
  Text
head <- IO Text
gitHead
  Maybe Text
maybeUpstreamHead <- Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
branch
  Bool
existRemoteCommits <- IO Bool -> (Text -> IO Bool) -> Maybe Text -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (Text -> Text -> IO Bool
gitExistCommitsBetween Text
head) Maybe Text
maybeUpstreamHead
  Bool
existLocalCommits <- IO Bool -> (Text -> IO Bool) -> Maybe Text -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (\Text
upstreamHead -> Text -> Text -> IO Bool
gitExistCommitsBetween Text
upstreamHead Text
"HEAD") Maybe Text
maybeUpstreamHead
  MitState ()
state0 <- Text -> IO (MitState ())
readMitState Text
branch64

  let wouldFork :: Bool
wouldFork = Bool
existRemoteCommits Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
existLocalCommits
  let shouldWarnAboutFork :: IO Bool
shouldWarnAboutFork =
        case Bool
wouldFork of
          Bool
False -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Bool
True -> do
            let theyRanMitCommitRecently :: IO Bool
theyRanMitCommitRecently =
                  case MitState ()
state0.ranCommitAt of
                    Maybe Integer
Nothing -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    Just Integer
t0 -> do
                      Integer
t1 <- TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Integer) -> IO TimeSpec -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Realtime
                      Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer
t1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
t0) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
10_000_000_000)
            Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
theyRanMitCommitRecently

  -- Bail out early if we should warn that this commit would fork history
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
shouldWarnAboutFork do
    Maybe Integer
ranCommitAt <- Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (TimeSpec -> Integer) -> TimeSpec -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Maybe Integer) -> IO TimeSpec -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Realtime
    Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState ()
state0 {Maybe Integer
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt :: Maybe Integer
ranCommitAt}
    [Text] -> IO ()
putLines
      [ Text
"",
        Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.italic Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not up to date.",
        Text
"",
        Text
"  Run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold (Text -> Text
Text.blue Text
"mit sync") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" first, or run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold (Text -> Text
Text.blue Text
"mit commit")
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" again to record a commit anyway.",
        Text
""
      ]
    IO ()
forall a. IO a
exitFailure

  Text
stash <- IO Text
gitCreateStash
  Bool
committed <- IO Bool
gitCommit
  [GitCommitInfo]
localCommits <- Maybe Text -> Text -> IO [GitCommitInfo]
gitCommitsBetween Maybe Text
maybeUpstreamHead Text
"HEAD"

  PushResult
pushResult <-
    case ([GitCommitInfo]
localCommits, Bool
existRemoteCommits, Bool
fetched) of
      ([], Bool
_, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
NothingToPush)
      (GitCommitInfo
_ : [GitCommitInfo]
_, Bool
True, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
ForkedHistory)
      (GitCommitInfo
_ : [GitCommitInfo]
_, Bool
False, Bool
False) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
Offline)
      (GitCommitInfo
_ : [GitCommitInfo]
_, Bool
False, Bool
True) -> Bool -> PushResult
PushAttempted (Bool -> PushResult) -> IO Bool -> IO PushResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Bool
gitPush Text
branch

  let pushed :: Bool
pushed =
        case PushResult
pushResult of
          PushAttempted Bool
success -> Bool
success
          PushNotAttempted PushNotAttemptedReason
_ -> Bool
False

  -- Only bother resetting the "ran commit at" if we would fork and the commit was aborted
  Maybe Integer
ranCommitAt <-
    case (Bool
wouldFork, Bool
committed) of
      (Bool
True, Bool
False) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (TimeSpec -> Integer) -> TimeSpec -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Maybe Integer) -> IO TimeSpec -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Realtime
      (Bool, Bool)
_ -> Maybe Integer -> IO (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing

  [Undo]
undos <-
    case (Bool
pushed, Bool
committed, [GitCommitInfo]
localCommits) of
      (Bool
False, Bool
False, [GitCommitInfo]
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
state0.undos
      (Bool
False, Bool
True, [GitCommitInfo]
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Undo
Reset Text
head, Text -> Undo
Apply Text
stash]
      (Bool
True, Bool
True, [GitCommitInfo
_]) -> do
        Text
head1 <- IO Text
gitHead
        [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Undo
Revert Text
head1, Text -> Undo
Apply Text
stash]
      (Bool
True, Bool
_, [GitCommitInfo]
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState {$sel:head:MitState :: ()
head = (), $sel:merging:MitState :: Maybe Text
merging = Maybe Text
forall a. Maybe a
Nothing, Maybe Integer
ranCommitAt :: Maybe Integer
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt, [Undo]
$sel:undos:MitState :: [Undo]
undos :: [Undo]
undos}

  Summary -> IO ()
putSummary
    Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
      { Text
$sel:branch:Summary :: Text
branch :: Text
branch,
        -- Whether we "can undo" from here is not exactly if the state says we can undo, because of one corner case:
        -- we ran 'mit commit', then aborted the commit, and ultimately didn't push any other local changes.
        --
        -- In this case, the underlying state hasn't changed, so 'mit undo' will still work as if the 'mit commit'
        -- was never run, we merely don't want to *say* "run 'mit undo' to undo" as feedback, because that sounds as
        -- if it would undo the last command run, namely the 'mit commit' that was aborted.
        $sel:canUndo:Summary :: Bool
canUndo = Bool -> Bool
not ([Undo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Undo]
undos) Bool -> Bool -> Bool
&& Bool
committed,
        $sel:conflicts:Summary :: [GitConflict]
conflicts = [],
        $sel:syncs:Summary :: [Sync]
syncs =
          case [GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitCommitInfo]
localCommits of
            Maybe (NonEmpty GitCommitInfo)
Nothing -> []
            Just NonEmpty GitCommitInfo
commits ->
              [ Sync :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
                  { NonEmpty GitCommitInfo
$sel:commits:Sync :: NonEmpty GitCommitInfo
commits :: NonEmpty GitCommitInfo
commits,
                    $sel:result:Sync :: SyncResult
result = PushResult -> SyncResult
pushResultToSyncResult PushResult
pushResult,
                    $sel:source:Sync :: Text
source = Text
branch,
                    $sel:target:Sync :: Text
target = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
                  }
              ]
      }

mitCommitMerge :: IO ()
mitCommitMerge :: IO ()
mitCommitMerge = do
  Text
branch <- IO Text
gitCurrentBranch
  let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
  Text
head <- IO Text
gitHead
  MitState ()
state0 <- Text -> IO (MitState ())
readMitState Text
branch64

  case MitState ()
state0.merging of
    Maybe Text
Nothing -> [Text] -> IO ()
git_ [Text
"commit", Text
"--all", Text
"--no-edit"]
    Just Text
merging ->
      let message :: Text
message = [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Text
"⅄ ", if Text
merging Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
branch then Text
"" else Text
merging Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → ", Text
branch]
       in [Text] -> IO ()
git_ [Text
"commit", Text
"--all", Text
"--message", Text
message]
  case [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text
commit | Apply Text
commit <- MitState ()
state0.undos] of
    Maybe Text
Nothing -> Maybe [Undo] -> IO ()
mitSyncWith ([Undo] -> Maybe [Undo]
forall a. a -> Maybe a
Just [Text -> Undo
Reset Text
head])
    Just Text
stash ->
      Text -> IO [GitConflict]
gitApplyStash Text
stash IO [GitConflict] -> ([GitConflict] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- FIXME we just unstashed, now we're about to stash again :/
        [] -> Maybe [Undo] -> IO ()
mitSyncWith ([Undo] -> Maybe [Undo]
forall a. a -> Maybe a
Just [Text -> Undo
Reset Text
head, Text -> Undo
Apply Text
stash])
        [GitConflict]
conflicts -> do
          Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState ()
state0 {$sel:merging:MitState :: Maybe Text
merging = Maybe Text
forall a. Maybe a
Nothing, $sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing}
          Summary -> IO ()
putSummary
            Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
              { Text
branch :: Text
$sel:branch:Summary :: Text
branch,
                $sel:canUndo:Summary :: Bool
canUndo = Bool -> Bool
not ([Undo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MitState ()
state0.undos),
                [GitConflict]
conflicts :: [GitConflict]
$sel:conflicts:Summary :: [GitConflict]
conflicts,
                $sel:syncs:Summary :: [Sync]
syncs = []
              }

data PushResult
  = PushAttempted Bool
  | PushNotAttempted PushNotAttemptedReason

data PushNotAttemptedReason
  = ForkedHistory -- local history has forked, need to sync
  | NothingToPush -- no commits to push
  | Offline -- fetch failed, so we seem offline
  | UnseenCommits -- we just pulled remote commits; don't push in case there's something local to address

pushResultToSyncResult :: PushResult -> SyncResult
pushResultToSyncResult :: PushResult -> SyncResult
pushResultToSyncResult = \case
  PushAttempted Bool
False -> SyncResult
SyncResult'Failure
  PushAttempted Bool
True -> SyncResult
SyncResult'Success
  PushNotAttempted PushNotAttemptedReason
ForkedHistory -> SyncResult
SyncResult'Failure
  PushNotAttempted PushNotAttemptedReason
NothingToPush -> SyncResult
SyncResult'Success -- doesnt matter, wont be shown
  PushNotAttempted PushNotAttemptedReason
Offline -> SyncResult
SyncResult'Offline
  PushNotAttempted PushNotAttemptedReason
UnseenCommits -> SyncResult
SyncResult'Pending

-- FIXME if on branch 'foo', handle 'mitMerge foo' or 'mitMerge origin/foo' as 'mitSync'?
mitMerge :: Text -> IO ()
mitMerge :: Text -> IO ()
mitMerge Text
target = do
  IO ()
dieIfNotInGitDir
  IO ()
dieIfMergeInProgress
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitExistUntrackedFiles IO ()
dieIfBuggyGit

  Text
branch <- IO Text
gitCurrentBranch
  let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch

  -- When given 'mit merge foo', prefer merging 'origin/foo' over 'foo'
  Text
targetCommit <- do
    Bool
_fetched <- Text -> IO Bool
gitFetch Text
"origin"
    Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
target IO (Maybe Text) -> (IO (Maybe Text) -> IO Text) -> IO Text
forall a b. a -> (a -> b) -> b
& IO Text -> IO (Maybe Text) -> IO Text
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM ([Text] -> IO (Either ExitCode Text)
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
target] IO (Either ExitCode Text)
-> (IO (Either ExitCode Text) -> IO Text) -> IO Text
forall a b. a -> (a -> b) -> b
& (ExitCode -> IO Text) -> IO (Either ExitCode Text) -> IO Text
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM \ExitCode
_ -> IO Text
forall a. IO a
exitFailure)

  Maybe MergeStatus
maybeMergeStatus <- Text -> Text -> IO (Maybe MergeStatus)
mitMerge' (Text
"⅄ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch) Text
targetCommit

  Text -> MitState () -> IO ()
writeMitState
    Text
branch64
    MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState
      { $sel:head:MitState :: ()
head = (),
        $sel:merging:MitState :: Maybe Text
merging = do
          MergeStatus
mergeStatus <- Maybe MergeStatus
maybeMergeStatus
          case MergeStatus
mergeStatus.result of
            MergeResult'MergeConflicts List1 GitConflict
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
target
            MergeResult'StashConflicts [GitConflict]
_ -> Maybe Text
forall a. Maybe a
Nothing,
        $sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing,
        $sel:undos:MitState :: [Undo]
undos =
          case Maybe MergeStatus
maybeMergeStatus of
            Maybe MergeStatus
Nothing -> []
            Just MergeStatus
mergeStatus -> MergeStatus
mergeStatus.undos
      }

  Summary -> IO ()
putSummary
    Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
      { Text
branch :: Text
$sel:branch:Summary :: Text
branch,
        $sel:canUndo:Summary :: Bool
canUndo = Maybe MergeStatus -> Bool
forall a. Maybe a -> Bool
isJust Maybe MergeStatus
maybeMergeStatus,
        $sel:conflicts:Summary :: [GitConflict]
conflicts =
          case Maybe MergeStatus
maybeMergeStatus of
            Maybe MergeStatus
Nothing -> []
            Just MergeStatus
mergeStatus ->
              case MergeStatus
mergeStatus.result of
                MergeResult'MergeConflicts List1 GitConflict
conflicts -> List1 GitConflict -> [GitConflict]
forall a. NonEmpty a -> [a]
List1.toList List1 GitConflict
conflicts
                MergeResult'StashConflicts [GitConflict]
conflicts -> [GitConflict]
conflicts,
        $sel:syncs:Summary :: [Sync]
syncs = do
          MergeStatus
mergeStatus <- Maybe MergeStatus -> [MergeStatus]
forall a. Maybe a -> [a]
maybeToList Maybe MergeStatus
maybeMergeStatus
          Sync -> [Sync]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Sync :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
              { $sel:commits:Sync :: NonEmpty GitCommitInfo
commits = MergeStatus
mergeStatus.commits,
                $sel:result:Sync :: SyncResult
result =
                  case MergeStatus
mergeStatus.result of
                    MergeResult'MergeConflicts List1 GitConflict
_ -> SyncResult
SyncResult'Failure
                    -- Even if we have conflicts from unstashing, we call this merge a success.
                    MergeResult'StashConflicts [GitConflict]
_ -> SyncResult
SyncResult'Success,
                $sel:source:Sync :: Text
source = Text
target,
                $sel:target:Sync :: Text
target = Text
branch
              }
      }

data MergeStatus = MergeStatus
  { MergeStatus -> NonEmpty GitCommitInfo
commits :: List1 GitCommitInfo,
    MergeStatus -> MergeResult
result :: MergeResult,
    MergeStatus -> [Undo]
undos :: [Undo] -- FIXME List1
  }

data MergeResult
  = MergeResult'MergeConflicts (List1 GitConflict)
  | MergeResult'StashConflicts [GitConflict]

mitMerge' :: Text -> Text -> IO (Maybe MergeStatus)
mitMerge' :: Text -> Text -> IO (Maybe MergeStatus)
mitMerge' Text
message Text
target = do
  Text
head <- IO Text
gitHead
  ([GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty ([GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo))
-> IO [GitCommitInfo] -> IO (Maybe (NonEmpty GitCommitInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> Text -> IO [GitCommitInfo]
gitCommitsBetween (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
head) Text
target) IO (Maybe (NonEmpty GitCommitInfo))
-> (Maybe (NonEmpty GitCommitInfo) -> IO (Maybe MergeStatus))
-> IO (Maybe MergeStatus)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (NonEmpty GitCommitInfo)
Nothing -> Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MergeStatus
forall a. Maybe a
Nothing
    Just NonEmpty GitCommitInfo
commits -> do
      Maybe Text
maybeStash <- IO (Maybe Text)
gitStash
      let undos :: [Undo]
undos = Text -> Undo
Reset Text
head Undo -> [Undo] -> [Undo]
forall a. a -> [a] -> [a]
: Maybe Undo -> [Undo]
forall a. Maybe a -> [a]
maybeToList (Text -> Undo
Apply (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybeStash)
      MergeResult
result <-
        [Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"merge", Text
"--ff", Text
"--no-commit", Text
target] IO Bool -> (Bool -> IO MergeResult) -> IO MergeResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
False -> do
            [GitConflict]
conflicts <- IO [GitConflict]
gitConflicts
            MergeResult -> IO MergeResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (List1 GitConflict -> MergeResult
MergeResult'MergeConflicts ([GitConflict] -> List1 GitConflict
forall a. [a] -> NonEmpty a
List1.fromList [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", Text
message])
            Maybe [GitConflict]
maybeConflicts <- Maybe Text
-> (Text -> IO [GitConflict]) -> IO (Maybe [GitConflict])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Text
maybeStash Text -> IO [GitConflict]
gitApplyStash
            MergeResult -> IO MergeResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GitConflict] -> MergeResult
MergeResult'StashConflicts ([GitConflict] -> Maybe [GitConflict] -> [GitConflict]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [GitConflict]
maybeConflicts))
      Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeStatus -> Maybe MergeStatus
forall a. a -> Maybe a
Just MergeStatus :: NonEmpty GitCommitInfo -> MergeResult -> [Undo] -> MergeStatus
MergeStatus {NonEmpty GitCommitInfo
commits :: NonEmpty GitCommitInfo
$sel:commits:MergeStatus :: NonEmpty GitCommitInfo
commits, MergeResult
result :: MergeResult
$sel:result:MergeStatus :: MergeResult
result, [Undo]
undos :: [Undo]
$sel:undos:MergeStatus :: [Undo]
undos})

-- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream
mitSync :: IO ()
mitSync :: IO ()
mitSync = do
  IO ()
dieIfNotInGitDir
  IO ()
dieIfMergeInProgress
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitExistUntrackedFiles IO ()
dieIfBuggyGit
  Maybe [Undo] -> IO ()
mitSyncWith Maybe [Undo]
forall a. Maybe a
Nothing

-- | @mitSyncWith maybeUndos@
--
-- Whenever recording what 'mit undo' should do after 'mit sync', if 'maybeUndos' is provided, we use them instead.
-- This is pulled into a function argument to get better undo behavior after committing a merge.
--
-- Consider:
--
-- The user runs 'mit merge foo' (with or without a clean working tree), and gets conflicts. After fixing them, she runs
-- 'mit commit'. This may result in *additional* conflicts due to the just-stashed uncommitted changes.
--
-- But either way, internally, we would like this 'mit commit' to effectively behave as a normal commit, in the sense
-- that we want to immediately push it upstream. That means the code would like to simply call 'mit sync' after
-- 'git commit'!
--
-- However, if this commit could be undone (i.e. we didn't push it), we wouldn't want that 'mit sync' to *locally*
-- compute where to undo, because it would just conclude, "oh, HEAD hasn't moved, and we didn't push, so there's nothing
-- to undo".
--
-- Instead, we want to undo to the point before running the 'mit merge' that caused the conflicts, which were later
-- resolved by 'mit commit'.
mitSyncWith :: Maybe [Undo] -> IO ()
mitSyncWith :: Maybe [Undo] -> IO ()
mitSyncWith Maybe [Undo]
maybeUndos = do
  Bool
fetched <- Text -> IO Bool
gitFetch Text
"origin"
  Text
branch <- IO Text
gitCurrentBranch
  let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
  Maybe Text
maybeUpstreamHead <- Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
branch

  Maybe MergeStatus
maybeMergeStatus <-
    case Maybe Text
maybeUpstreamHead of
      Maybe Text
Nothing -> Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MergeStatus
forall a. Maybe a
Nothing
      Just Text
upstreamHead -> Text -> Text -> IO (Maybe MergeStatus)
mitMerge' (Text
"⅄ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch) Text
upstreamHead

  [GitCommitInfo]
localCommits <- Maybe Text -> Text -> IO [GitCommitInfo]
gitCommitsBetween Maybe Text
maybeUpstreamHead Text
"HEAD"

  PushResult
pushResult <-
    case ([GitCommitInfo]
localCommits, (.result) (MergeStatus -> MergeResult)
-> Maybe MergeStatus -> Maybe MergeResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MergeStatus
maybeMergeStatus, Bool
fetched) of
      ([], Maybe MergeResult
_, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
NothingToPush)
      -- "forked history" is ok - a bit different than history *already* having forked, in which case a push
      -- would just fail, whereas this is just us choosing not to push while in the middle of a merge due to a
      -- previous fork in the history
      (GitCommitInfo
_ : [GitCommitInfo]
_, Just (MergeResult'MergeConflicts List1 GitConflict
_), Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
ForkedHistory)
      (GitCommitInfo
_ : [GitCommitInfo]
_, Just (MergeResult'StashConflicts [GitConflict]
_), Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
UnseenCommits)
      (GitCommitInfo
_ : [GitCommitInfo]
_, Maybe MergeResult
Nothing, Bool
False) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
Offline)
      (GitCommitInfo
_ : [GitCommitInfo]
_, Maybe MergeResult
Nothing, Bool
True) -> Bool -> PushResult
PushAttempted (Bool -> PushResult) -> IO Bool -> IO PushResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Bool
gitPush Text
branch

  let pushed :: Bool
pushed =
        case PushResult
pushResult of
          PushAttempted Bool
success -> Bool
success
          PushNotAttempted PushNotAttemptedReason
_ -> Bool
False

  let undos :: [Undo]
undos =
        case Bool
pushed of
          Bool
False -> [Undo] -> Maybe [Undo] -> [Undo]
forall a. a -> Maybe a -> a
fromMaybe ([Undo] -> (MergeStatus -> [Undo]) -> Maybe MergeStatus -> [Undo]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (.undos) Maybe MergeStatus
maybeMergeStatus) Maybe [Undo]
maybeUndos
          Bool
True -> []

  Text -> MitState () -> IO ()
writeMitState
    Text
branch64
    MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState
      { $sel:head:MitState :: ()
head = (),
        $sel:merging:MitState :: Maybe Text
merging = do
          MergeStatus
mergeStatus <- Maybe MergeStatus
maybeMergeStatus
          case MergeStatus
mergeStatus.result of
            MergeResult'MergeConflicts List1 GitConflict
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch
            MergeResult'StashConflicts [GitConflict]
_ -> Maybe Text
forall a. Maybe a
Nothing,
        $sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing,
        [Undo]
undos :: [Undo]
$sel:undos:MitState :: [Undo]
undos
      }

  Summary -> IO ()
putSummary
    Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
      { Text
branch :: Text
$sel:branch:Summary :: Text
branch,
        $sel:canUndo:Summary :: Bool
canUndo = Bool -> Bool
not ([Undo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Undo]
undos),
        $sel:conflicts:Summary :: [GitConflict]
conflicts =
          case Maybe MergeStatus
maybeMergeStatus of
            Maybe MergeStatus
Nothing -> []
            Just MergeStatus
mergeStatus ->
              case MergeStatus
mergeStatus.result of
                MergeResult'MergeConflicts List1 GitConflict
conflicts -> List1 GitConflict -> [GitConflict]
forall a. NonEmpty a -> [a]
List1.toList List1 GitConflict
conflicts
                MergeResult'StashConflicts [GitConflict]
conflicts -> [GitConflict]
conflicts,
        $sel:syncs:Summary :: [Sync]
syncs =
          [Maybe Sync] -> [Sync]
forall a. [Maybe a] -> [a]
catMaybes
            [ do
                MergeStatus
mergeStatus <- Maybe MergeStatus
maybeMergeStatus
                Sync -> Maybe Sync
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  Sync :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
                    { $sel:commits:Sync :: NonEmpty GitCommitInfo
commits = MergeStatus
mergeStatus.commits,
                      $sel:result:Sync :: SyncResult
result =
                        case MergeStatus
mergeStatus.result of
                          MergeResult'MergeConflicts List1 GitConflict
_ -> SyncResult
SyncResult'Failure
                          MergeResult'StashConflicts [GitConflict]
_ -> SyncResult
SyncResult'Success,
                      $sel:source:Sync :: Text
source = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch,
                      $sel:target:Sync :: Text
target = Text
branch
                    },
              do
                NonEmpty GitCommitInfo
commits <- [GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitCommitInfo]
localCommits
                Sync -> Maybe Sync
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  Sync :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
                    { NonEmpty GitCommitInfo
commits :: NonEmpty GitCommitInfo
$sel:commits:Sync :: NonEmpty GitCommitInfo
commits,
                      $sel:result:Sync :: SyncResult
result = PushResult -> SyncResult
pushResultToSyncResult PushResult
pushResult,
                      $sel:source:Sync :: Text
source = Text
branch,
                      $sel:target:Sync :: Text
target = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
                    }
            ]
      }

-- FIXME output what we just undid
mitUndo :: IO ()
mitUndo :: IO ()
mitUndo = do
  IO ()
dieIfNotInGitDir

  Text
branch64 <- Text -> Text
Text.encodeBase64 (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
gitCurrentBranch
  MitState ()
state0 <- Text -> IO (MitState ())
readMitState Text
branch64
  case [Undo] -> Maybe (NonEmpty Undo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty MitState ()
state0.undos of
    Maybe (NonEmpty Undo)
Nothing -> IO ()
forall a. IO a
exitFailure
    Just NonEmpty Undo
undos1 -> NonEmpty Undo -> IO ()
applyUndos NonEmpty Undo
undos1
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Undo] -> Bool
undosContainRevert MitState ()
state0.undos) IO ()
mitSync
  where
    undosContainRevert :: [Undo] -> Bool
    undosContainRevert :: [Undo] -> Bool
undosContainRevert = \case
      [] -> Bool
False
      Revert Text
_ : [Undo]
_ -> Bool
True
      Undo
_ : [Undo]
undos -> [Undo] -> Bool
undosContainRevert [Undo]
undos

data Summary = Summary
  { Summary -> Text
branch :: Text,
    Summary -> Bool
canUndo :: Bool,
    Summary -> [GitConflict]
conflicts :: [GitConflict],
    Summary -> [Sync]
syncs :: [Sync]
  }

data Sync = Sync
  { Sync -> NonEmpty GitCommitInfo
commits :: List1 GitCommitInfo,
    Sync -> SyncResult
result :: SyncResult,
    Sync -> Text
source :: Text,
    Sync -> Text
target :: Text
  }

data SyncResult
  = SyncResult'Failure
  | SyncResult'Offline
  | SyncResult'Pending
  | SyncResult'Success

-- FIXME show some graph of where local/remote is at
putSummary :: Summary -> IO ()
putSummary :: Summary -> IO ()
putSummary Summary
summary =
  let output :: [Text]
output = (Sync -> [Text]) -> [Sync] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Sync -> [Text]
syncLines Summary
summary.syncs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
conflictsLines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
undoLines
   in if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
output then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else [Text] -> IO ()
putLines (Text
"" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
output)
  where
    conflictsLines :: [Text]
    conflictsLines :: [Text]
conflictsLines =
      if [GitConflict] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Summary
summary.conflicts
        then []
        else
          Text
"  The following files have conflicts." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
          (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
. Text -> Text
Text.red (Text -> Text) -> (GitConflict -> Text) -> GitConflict -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitConflict -> Text
showGitConflict) Summary
summary.conflicts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
""]
    syncLines :: Sync -> [Text]
    syncLines :: Sync -> [Text]
syncLines Sync
sync =
      Text -> Text
colorize (Text -> Text
Text.italic (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sync
sync.source Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sync
sync.target)) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
      (GitCommitInfo -> Text) -> [GitCommitInfo] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (GitCommitInfo -> Text) -> GitCommitInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitCommitInfo -> Text
prettyGitCommitInfo) (NonEmpty GitCommitInfo -> [GitCommitInfo]
forall a. NonEmpty a -> [a]
List1.toList Sync
sync.commits)
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
""]
      where
        colorize :: Text -> Text
        colorize :: Text -> Text
colorize =
          case Sync
sync.result of
            SyncResult
SyncResult'Failure -> Text -> Text
Text.red
            SyncResult
SyncResult'Offline -> Text -> Text
Text.brightBlack
            SyncResult
SyncResult'Pending -> Text -> Text
Text.yellow
            SyncResult
SyncResult'Success -> Text -> Text
Text.green
    undoLines :: [Text]
    undoLines :: [Text]
undoLines =
      if Summary
summary.canUndo
        then [Text
"  Run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold (Text -> Text
Text.blue Text
"mit undo") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to undo this change.", Text
""]
        else []

-- State file

data MitState a = MitState
  { MitState a -> a
head :: a,
    MitState a -> Maybe Text
merging :: Maybe Text,
    MitState a -> Maybe Integer
ranCommitAt :: Maybe Integer,
    MitState a -> [Undo]
undos :: [Undo]
  }
  deriving stock (MitState a -> MitState a -> Bool
(MitState a -> MitState a -> Bool)
-> (MitState a -> MitState a -> Bool) -> Eq (MitState a)
forall a. Eq a => MitState a -> MitState a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MitState a -> MitState a -> Bool
$c/= :: forall a. Eq a => MitState a -> MitState a -> Bool
== :: MitState a -> MitState a -> Bool
$c== :: forall a. Eq a => MitState a -> MitState a -> Bool
Eq, Int -> MitState a -> ShowS
[MitState a] -> ShowS
MitState a -> String
(Int -> MitState a -> ShowS)
-> (MitState a -> String)
-> ([MitState a] -> ShowS)
-> Show (MitState a)
forall a. Show a => Int -> MitState a -> ShowS
forall a. Show a => [MitState a] -> ShowS
forall a. Show a => MitState a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MitState a] -> ShowS
$cshowList :: forall a. Show a => [MitState a] -> ShowS
show :: MitState a -> String
$cshow :: forall a. Show a => MitState a -> String
showsPrec :: Int -> MitState a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MitState a -> ShowS
Show)

emptyMitState :: MitState ()
emptyMitState :: MitState ()
emptyMitState =
  MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState {$sel:head:MitState :: ()
head = (), $sel:merging:MitState :: Maybe Text
merging = Maybe Text
forall a. Maybe a
Nothing, $sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing, $sel:undos:MitState :: [Undo]
undos = []}

deleteMitState :: Text -> IO ()
deleteMitState :: Text -> IO ()
deleteMitState Text
branch64 =
  String -> IO ()
removeFile (Text -> String
mitfile Text
branch64) IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

parseMitState :: Text -> Maybe (MitState Text)
parseMitState :: Text -> Maybe (MitState Text)
parseMitState Text
contents = do
  [Text
headLine, Text
mergingLine, Text
ranCommitAtLine, Text
undosLine] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Text -> [Text]
Text.lines Text
contents)
  [Text
"head", Text
head] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Text -> [Text]
Text.words Text
headLine)
  Maybe Text
merging <-
    case Text -> [Text]
Text.words Text
mergingLine of
      [Text
"merging"] -> Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just Maybe Text
forall a. Maybe a
Nothing
      [Text
"merging", Text
branch] -> Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch)
      [Text]
_ -> Maybe (Maybe Text)
forall a. Maybe a
Nothing
  Maybe Integer
ranCommitAt <-
    case Text -> [Text]
Text.words Text
ranCommitAtLine of
      [Text
"ran-commit-at"] -> Maybe Integer -> Maybe (Maybe Integer)
forall a. a -> Maybe a
Just Maybe Integer
forall a. Maybe a
Nothing
      [Text
"ran-commit-at", Text -> Maybe Integer
text2int -> Just Integer
n] -> Maybe Integer -> Maybe (Maybe Integer)
forall a. a -> Maybe a
Just (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n)
      [Text]
_ -> Maybe (Maybe Integer)
forall a. Maybe a
Nothing
  [Undo]
undos <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"undos " Text
undosLine Maybe Text -> (Text -> Maybe [Undo]) -> Maybe [Undo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe [Undo]
parseUndos
  MitState Text -> Maybe (MitState Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState {Text
head :: Text
$sel:head:MitState :: Text
head, Maybe Text
merging :: Maybe Text
$sel:merging:MitState :: Maybe Text
merging, Maybe Integer
ranCommitAt :: Maybe Integer
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt, [Undo]
undos :: [Undo]
$sel:undos:MitState :: [Undo]
undos}

readMitState :: Text -> IO (MitState ())
readMitState :: Text -> IO (MitState ())
readMitState Text
branch64 = do
  Text
head <- IO Text
gitHead
  IO Text -> IO (Either IOException Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO Text
Text.readFile (Text -> String
mitfile Text
branch64)) IO (Either IOException Text)
-> (Either IOException Text -> IO (MitState ()))
-> IO (MitState ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (IOException
_ :: IOException) -> MitState () -> IO (MitState ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
emptyMitState
    Right Text
contents -> do
      let maybeState :: Maybe (MitState Text)
maybeState = do
            MitState Text
state <- Text -> Maybe (MitState Text)
parseMitState Text
contents
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
head Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== MitState Text
state.head)
            MitState Text -> Maybe (MitState Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState Text
state
      case Maybe (MitState Text)
maybeState of
        Maybe (MitState Text)
Nothing -> do
          Text -> IO ()
deleteMitState Text
branch64
          MitState () -> IO (MitState ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
emptyMitState
        Just MitState Text
state -> MitState () -> IO (MitState ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MitState Text
state {$sel:head:MitState :: ()
head = ()} :: MitState ())

writeMitState :: Text -> MitState () -> IO ()
writeMitState :: Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState ()
state = do
  Text
head <- IO Text
gitHead
  let contents :: Text
      contents :: Text
contents =
        [Text] -> Text
Text.unlines
          [ Text
"head " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
head,
            Text
"merging " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
Text.empty MitState ()
state.merging,
            Text
"ran-commit-at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Integer -> Text) -> Maybe Integer -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty Integer -> Text
int2text MitState ()
state.ranCommitAt,
            Text
"undos " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Undo] -> Text
showUndos MitState ()
state.undos
          ]
  String -> Text -> IO ()
Text.writeFile (Text -> String
mitfile Text
branch64) Text
contents IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mitfile :: Text -> FilePath
mitfile :: Text -> String
mitfile Text
branch64 =
  Text -> String
Text.unpack (Text
gitdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/.mit-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch64)

-- Undo file utils

data Undo
  = Apply Text -- apply stash
  | Reset Text -- reset to commit
  | Revert Text -- revert commit
  deriving stock (Undo -> Undo -> Bool
(Undo -> Undo -> Bool) -> (Undo -> Undo -> Bool) -> Eq Undo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Undo -> Undo -> Bool
$c/= :: Undo -> Undo -> Bool
== :: Undo -> Undo -> Bool
$c== :: Undo -> Undo -> Bool
Eq, Int -> Undo -> ShowS
[Undo] -> ShowS
Undo -> String
(Int -> Undo -> ShowS)
-> (Undo -> String) -> ([Undo] -> ShowS) -> Show Undo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Undo] -> ShowS
$cshowList :: [Undo] -> ShowS
show :: Undo -> String
$cshow :: Undo -> String
showsPrec :: Int -> Undo -> ShowS
$cshowsPrec :: Int -> Undo -> ShowS
Show)

showUndos :: [Undo] -> Text
showUndos :: [Undo] -> Text
showUndos =
  Text -> [Text] -> Text
Text.intercalate Text
" " ([Text] -> Text) -> ([Undo] -> [Text]) -> [Undo] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Undo -> Text) -> [Undo] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Undo -> Text
showUndo
  where
    showUndo :: Undo -> Text
    showUndo :: Undo -> Text
showUndo = \case
      Apply Text
commit -> Text
"apply/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit
      Reset Text
commit -> Text
"reset/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit
      Revert Text
commit -> Text
"revert/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit

parseUndos :: Text -> Maybe [Undo]
parseUndos :: Text -> Maybe [Undo]
parseUndos Text
t0 = do
  (Text -> [Text]
Text.words (Text -> [Text])
-> ([Text] -> Maybe [Undo]) -> Text -> Maybe [Undo]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Text -> Maybe Undo) -> [Text] -> Maybe [Undo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Maybe Undo
parseUndo) Text
t0
  where
    parseUndo :: Text -> Maybe Undo
    parseUndo :: Text -> Maybe Undo
parseUndo Text
text =
      [Maybe Undo] -> Maybe Undo
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Text -> Undo
Apply (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
"apply/" Text
text,
          Text -> Undo
Reset (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
"reset/" Text
text,
          Text -> Undo
Revert (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
"revert/" Text
text,
          String -> Maybe Undo
forall a. HasCallStack => String -> a
error (Text -> String
forall a. Show a => a -> String
show Text
text)
        ]

applyUndos :: List1 Undo -> IO ()
applyUndos :: NonEmpty Undo -> IO ()
applyUndos =
  (Undo -> IO ()) -> NonEmpty Undo -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \case
    Apply Text
commit -> IO [GitConflict] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> IO [GitConflict]
gitApplyStash Text
commit)
    Reset Text
commit -> Text -> IO ()
gitResetHard Text
commit
    Revert Text
commit -> Text -> IO ()
gitRevert Text
commit