module Mit
  ( main,
  )
where

import Data.List.NonEmpty qualified as List1
import Data.Ord (clamp)
import Data.Sequence qualified as Seq
import Data.Text qualified as Text
import Data.Text.Builder.ANSI qualified as Text
import Data.Text.Lazy.Builder qualified as Text (Builder)
import Data.Text.Lazy.Builder qualified as Text.Builder
import Mit.Builder qualified as Builder
import Mit.Directory
import Mit.Env
import Mit.Git
import Mit.GitCommand qualified as Git
import Mit.Monad
import Mit.Prelude
import Mit.Seq1 qualified as Seq1
import Mit.Stanza
import Mit.State
import Mit.Undo
import Options.Applicative qualified as Opt
import Options.Applicative.Types qualified as Opt (Backtracking (Backtrack))
import System.Exit (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 more Seq, less []

-- TODO mit init
-- TODO mit delete-branch
-- TODO tweak things to work with git < 2.30.1
-- 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 undo revert
-- TODO more specific "undo this change" wording

main :: IO ()
main :: IO ()
main = do
  (Int
verbosity, MitCommand
command) <- forall a. ParserPrefs -> ParserInfo a -> IO a
Opt.customExecParser ParserPrefs
parserPrefs ParserInfo (Int, MitCommand)
parserInfo

  let action :: forall x. Mit () x [Stanza]
      action :: forall x. Mit () x [Stanza]
action = do
        forall r s x a. (r -> s) -> Mit s x a -> Mit r x a
withEnv (\() -> Env {$sel:gitdir:Env :: Text
gitdir = Text
"", Int
$sel:verbosity:Env :: Int
verbosity :: Int
verbosity}) forall x. Mit Env x (Maybe Text)
gitRevParseAbsoluteGitDir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. a -> Maybe a
Just (Builder -> Builder
Text.red Builder
"The current directory doesn't contain a git repository.")]
          Just Text
gitdir -> do
            forall r s x a. (r -> s) -> Mit s x a -> Mit r x a
withEnv
              (\() -> Env {Text
gitdir :: Text
$sel:gitdir:Env :: Text
gitdir, Int
$sel:verbosity:Env :: Int
verbosity :: Int
verbosity})
              ( do
                  forall r x a. (Goto r x a -> Mit r (X x a) a) -> Mit r x a
label \Goto Env x [Stanza]
return -> do
                    case MitCommand
command of
                      MitCommand'Branch Text
branch -> forall x. Goto Env x [Stanza] -> Text -> Mit Env (X x [Stanza]) ()
mitBranch Goto Env x [Stanza]
return Text
branch forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
                      MitCommand
MitCommand'Commit -> forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitCommit @x Goto Env x [Stanza]
return forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
                      MitCommand'Merge Text
branch -> forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Text -> Mit Env xx ()
mitMerge @x Goto Env x [Stanza]
return Text
branch forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
                      MitCommand
MitCommand'Sync -> forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitSync @x Goto Env x [Stanza]
return forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
                      MitCommand
MitCommand'Undo -> forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitUndo @x Goto Env x [Stanza]
return forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
              )

  forall r a. r -> Mit r a a -> IO a
runMit () forall x. Mit () x [Stanza]
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Stanza]
errs -> do
      [Stanza] -> IO ()
putStanzas [Stanza]
errs
      forall a. IO a
exitFailure
  where
    parserPrefs :: Opt.ParserPrefs
    parserPrefs :: ParserPrefs
parserPrefs =
      Opt.ParserPrefs
        { prefBacktrack :: Backtracking
prefBacktrack = Backtracking
Opt.Backtrack,
          prefColumns :: Int
prefColumns = Int
80,
          prefDisambiguate :: Bool
prefDisambiguate = Bool
True,
          prefHelpLongEquals :: Bool
prefHelpLongEquals = Bool
False,
          prefHelpShowGlobal :: Bool
prefHelpShowGlobal = Bool
True,
          prefMultiSuffix :: String
prefMultiSuffix = String
"+",
          prefShowHelpOnEmpty :: Bool
prefShowHelpOnEmpty = Bool
True,
          prefShowHelpOnError :: Bool
prefShowHelpOnError = Bool
True,
          prefTabulateFill :: Int
prefTabulateFill = Int
24 -- grabbed this from optparse-applicative
        }

    parserInfo :: Opt.ParserInfo (Int, MitCommand)
    parserInfo :: ParserInfo (Int, MitCommand)
parserInfo =
      forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info Parser (Int, MitCommand)
parser forall a b. (a -> b) -> a -> b
$
        forall a. String -> InfoMod a
Opt.progDesc String
"mit: a git wrapper with a streamlined UX"

    parser :: Opt.Parser (Int, MitCommand)
    parser :: Parser (Int, MitCommand)
parser =
      (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall a. Ord a => (a, a) -> a -> a
clamp (Int
0, Int
2)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReadM a -> Mod OptionFields a -> Parser a
Opt.option forall a. Read a => ReadM a
Opt.auto (forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"Verbosity" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"«n»" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opt.short Char
'v' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
Opt.value Int
0)
            )
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Mod CommandFields a -> Parser a
Opt.hsubparser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
          [ forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
"branch" forall a b. (a -> b) -> a -> b
$
              forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
                (Text -> MitCommand
MitCommand'Branch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod ArgumentFields s -> Parser s
Opt.strArgument (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"≪branch≫"))
                (forall a. String -> InfoMod a
Opt.progDesc String
"Create a new branch in a new worktree."),
            forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
"commit" forall a b. (a -> b) -> a -> b
$
              forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure MitCommand
MitCommand'Commit)
                (forall a. String -> InfoMod a
Opt.progDesc String
"Create a commit interactively."),
            forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
"merge" forall a b. (a -> b) -> a -> b
$
              forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
                (Text -> MitCommand
MitCommand'Merge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod ArgumentFields s -> Parser s
Opt.strArgument (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"≪branch≫"))
                (forall a. String -> InfoMod a
Opt.progDesc String
"Merge the given branch into the current branch."),
            forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
"sync" forall a b. (a -> b) -> a -> b
$
              forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure MitCommand
MitCommand'Sync)
                (forall a. String -> InfoMod a
Opt.progDesc String
"Sync with the remote named `origin`."),
            forall a. String -> ParserInfo a -> Mod CommandFields a
Opt.command String
"undo" forall a b. (a -> b) -> a -> b
$
              forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure MitCommand
MitCommand'Undo)
                (forall a. String -> InfoMod a
Opt.progDesc String
"Undo the last `mit` command (if possible).")
          ]

data MitCommand
  = MitCommand'Branch Text
  | MitCommand'Commit
  | MitCommand'Merge Text
  | MitCommand'Sync
  | MitCommand'Undo

dieIfBuggyGit :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()
dieIfBuggyGit :: forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
dieIfBuggyGit Goto Env x [Stanza]
return = do
  GitVersion
version <- forall x.
(forall void. [Stanza] -> Mit Env x void) -> Mit Env x GitVersion
gitVersion Goto Env x [Stanza]
return
  let validate :: (GitVersion, Builder)
-> [(GitVersion, Builder)] -> [(GitVersion, Builder)]
validate (GitVersion
ver, Builder
err) = if GitVersion
version forall a. Ord a => a -> a -> Bool
< GitVersion
ver then ((GitVersion
ver, Builder
err) forall a. a -> [a] -> [a]
:) else forall a. a -> a
id
  case forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (GitVersion, Builder)
-> [(GitVersion, Builder)] -> [(GitVersion, Builder)]
validate [] [(GitVersion, Builder)]
validations of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [(GitVersion, Builder)]
errors ->
      Goto Env x [Stanza]
return forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map
          ( \(GitVersion
ver, Builder
err) ->
              forall a. a -> Maybe a
Just
                ( Builder -> Builder
Text.red
                    ( Builder
"Prior to " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold Builder
"git" forall a. Semigroup a => a -> a -> a
<> Builder
" version "
                        forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.fromText (GitVersion -> Text
showGitVersion GitVersion
ver)
                        forall a. Semigroup a => a -> a -> a
<> Builder
", "
                        forall a. Semigroup a => a -> a -> a
<> Builder
err
                    )
                )
          )
          [(GitVersion, Builder)]
errors
  where
    validations :: [(GitVersion, Text.Builder)]
    validations :: [(GitVersion, Builder)]
validations =
      [ ( Int -> Int -> Int -> GitVersion
GitVersion Int
2 Int
29 Int
0,
          Builder -> Builder
Text.bold Builder
"git commit --patch"
            forall a. Semigroup a => a -> a -> a
<> Builder
" was broken for new files added with "
            forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold Builder
"git add --intent-to-add"
            forall a. Semigroup a => a -> a -> a
<> Builder
"."
        ),
        ( Int -> Int -> Int -> GitVersion
GitVersion Int
2 Int
30 Int
1,
          Builder -> Builder
Text.bold Builder
"git stash create"
            forall a. Semigroup a => a -> a -> a
<> Builder
" was broken for new files added with "
            forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold Builder
"git add --intent-to-add"
            forall a. Semigroup a => a -> a -> a
<> Builder
"."
        )
      ]

dieIfMergeInProgress :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
dieIfMergeInProgress :: forall x. (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
dieIfMergeInProgress forall void. [Stanza] -> Mit Env x void
return =
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall x. Mit Env x Bool
gitMergeInProgress (forall void. [Stanza] -> Mit Env x void
return [forall a. a -> Maybe a
Just (Builder -> Builder
Text.red (Builder -> Builder
Text.bold Builder
"git merge" forall a. Semigroup a => a -> a -> a
<> Builder
" in progress."))])

mitBranch ::
  Goto Env x [Stanza] ->
  Text ->
  Mit Env (X x [Stanza]) ()
mitBranch :: forall x. Goto Env x [Stanza] -> Text -> Mit Env (X x [Stanza]) ()
mitBranch Goto Env x [Stanza]
return Text
branch = do
  Text
worktreeDir <- do
    Text
rootdir <- forall x. Mit Env x Text
gitRevParseShowToplevel
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Char -> Bool) -> Text -> Text
Text.dropWhileEnd (forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
rootdir forall a. Semigroup a => a -> a -> a
<> Text
branch)

  forall x. Text -> Mit Env x (Maybe Text)
gitBranchWorktreeDir Text
branch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Text
Nothing -> do
      forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). MonadIO m => Text -> m Bool
doesDirectoryExist Text
worktreeDir) do
        Goto Env x [Stanza]
return [forall a. a -> Maybe a
Just (Builder -> Builder
Text.red (Builder
"Directory " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Text -> Builder
Text.Builder.fromText Text
worktreeDir) forall a. Semigroup a => a -> a -> a
<> Builder
" already exists."))]
      forall x. [Text] -> Mit Env x ()
git_ [Text
"worktree", Text
"add", Text
"--detach", Text
worktreeDir]
      forall r x a. Text -> Mit r (X x a) a -> Mit r x a
cd Text
worktreeDir do
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenNotM (forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git (Text -> Command
Git.Switch Text
branch)) do
          forall x. Text -> Mit Env x ()
gitBranch Text
branch
          forall x. Command -> Mit Env x ()
Git.git_ (Text -> Command
Git.Switch Text
branch)
          forall x. Text -> Mit Env x ()
gitFetch_ Text
"origin"
          forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall x. Text -> Text -> Mit Env x Bool
gitRemoteBranchExists Text
"origin" Text
branch) do
            let upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Text
branch
            forall x. Command -> Mit Env x ()
Git.git_ (ResetMode -> FlagQuiet -> Text -> Command
Git.Reset ResetMode
Git.Hard FlagQuiet
Git.FlagQuiet Text
upstream)
            forall x. Command -> Mit Env x ()
Git.git_ (Text -> Command
Git.BranchSetUpstreamTo Text
upstream)
    Just Text
directory ->
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
directory forall a. Eq a => a -> a -> Bool
/= Text
worktreeDir) do
        Goto Env x [Stanza]
return
          [ forall a. a -> Maybe a
Just
              ( Builder -> Builder
Text.red
                  ( Builder -> Builder
Text.bold
                      ( Text -> Builder
Text.Builder.fromText Text
branch
                          forall a. Semigroup a => a -> a -> a
<> Builder
" is already checked out in "
                          forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Text -> Builder
Text.Builder.fromText Text
directory)
                      )
                      forall a. Semigroup a => a -> a -> a
<> Builder
"."
                  )
              )
          ]

mitCommit :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()
mitCommit :: forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitCommit Goto Env x [Stanza]
return = do
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall x. Mit Env x Bool
gitExistUntrackedFiles (forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
dieIfBuggyGit @x Goto Env x [Stanza]
return)

  forall x. Mit Env x Bool
gitMergeInProgress forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False ->
      forall x. Mit Env x DiffResult
gitDiff forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        DiffResult
Differences -> forall x. (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
mitCommit_ Goto Env x [Stanza]
return
        DiffResult
NoDifferences -> Goto Env x [Stanza]
return [forall a. a -> Maybe a
Just (Builder -> Builder
Text.red Builder
"There's nothing to commit.")]
    Bool
True -> forall x. Mit Env x ()
mitCommitMerge

mitCommit_ :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
mitCommit_ :: forall x. (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
mitCommit_ forall void. [Stanza] -> Mit Env x void
return = do
  Context
context <- forall x. Mit Env x Context
getContext
  let upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Context
context.branch

  Bool
existRemoteCommits <- forall x. Context -> Mit Env x Bool
contextExistRemoteCommits Context
context
  Bool
existLocalCommits <- forall x. Context -> Mit Env x Bool
contextExistLocalCommits Context
context

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
existRemoteCommits Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
existLocalCommits) do
    forall void. [Stanza] -> Mit Env x void
return
      [ Text -> Text -> Builder -> Stanza
notSynchronizedStanza Context
context.branch Text
upstream Builder
".",
        Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream
      ]

  Bool
committed <- forall x. Mit Env x Bool
gitCommit

  GitPush
push <- forall x. Text -> Mit Env x GitPush
performPush Context
context.branch

  let state :: MitState ()
state =
        MitState
          { $sel:head:MitState :: ()
head = (),
            $sel:merging:MitState :: Maybe Text
merging = forall a. Maybe a
Nothing,
            $sel:undos:MitState :: [Undo]
undos =
              case (GitPush -> Bool
pushPushed GitPush
push, Bool
committed) of
                (Bool
False, Bool
False) -> Context
context.state.undos
                (Bool
False, Bool
True) ->
                  case Context
context.snapshot of
                    Maybe GitSnapshot
Nothing -> []
                    Just GitSnapshot
snapshot -> GitSnapshot -> [Undo]
undoToSnapshot GitSnapshot
snapshot
                (Bool
True, Bool
False) -> GitPush
push.undo
                (Bool
True, Bool
True) ->
                  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitPush
push.undo
                    then []
                    else case Context
context.snapshot of
                      Maybe GitSnapshot
Nothing -> GitPush
push.undo
                      Just GitSnapshot
snapshot -> GitPush
push.undo forall a. [a] -> [a] -> [a]
++ [Text -> Undo
Apply (forall a. HasCallStack => Maybe a -> a
fromJust GitSnapshot
snapshot.stash)]
          }

  forall x. Text -> MitState () -> Mit Env x ()
writeMitState Context
context.branch MitState ()
state

  Seq GitCommitInfo
remoteCommits <-
    case Context
context.upstreamHead of
      Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Seq a
Seq.empty
      Just Text
upstreamHead -> forall x. Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo)
gitCommitsBetween (forall a. a -> Maybe a
Just Text
"HEAD") Text
upstreamHead

  [GitConflict]
conflictsOnSync <-
    if forall a. Seq a -> Bool
Seq.null Seq GitCommitInfo
remoteCommits
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else forall x. Text -> Mit Env x [GitConflict]
gitConflictsWith (forall a. HasCallStack => Maybe a -> a
fromJust Context
context.upstreamHead)

  forall a r x. IO a -> Mit r x a
io do
    [Stanza] -> IO ()
putStanzas
      [ Text -> GitPushWhat -> Stanza
isSynchronizedStanza2 Context
context.branch GitPush
push.what,
        do
          Seq1 GitCommitInfo
commits <- forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq Seq GitCommitInfo
remoteCommits
          Sync -> Stanza
syncStanza Sync {Seq1 GitCommitInfo
$sel:commits:Sync :: Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
commits, $sel:success:Sync :: Bool
success = Bool
False, $sel:source:Sync :: Text
source = Text
upstream, $sel:target:Sync :: Text
target = Context
context.branch},
        do
          Seq1 GitCommitInfo
commits <- forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq GitPush
push.commits
          Sync -> Stanza
syncStanza Sync {Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
$sel:commits:Sync :: Seq1 GitCommitInfo
commits, $sel:success:Sync :: Bool
success = GitPush -> Bool
pushPushed GitPush
push, $sel:source:Sync :: Text
source = Context
context.branch, $sel:target:Sync :: Text
target = Text
upstream},
        case GitPush
push.what of
          GitPushWhat
NothingToPush2 -> forall a. Maybe a
Nothing
          GitPushWhat
Pushed -> forall a. Maybe a
Nothing
          GitPushWhat
PushWouldntReachRemote -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"When you come online, run" Context
context.branch Text
upstream
          GitPushWhat
PushWouldBeRejected ->
            case forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitConflict]
conflictsOnSync of
              Maybe (NonEmpty GitConflict)
Nothing -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream
              Just NonEmpty GitConflict
conflictsOnSync1 ->
                [Stanza] -> Stanza
renderStanzas
                  [ Builder -> NonEmpty GitConflict -> Stanza
conflictsStanza
                      ( Builder
"These files will be in conflict when you run "
                          forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit sync")
                          forall a. Semigroup a => a -> a -> a
<> Builder
":"
                      )
                      NonEmpty GitConflict
conflictsOnSync1,
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                      Builder
"  Run "
                        forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit sync")
                        forall a. Semigroup a => a -> a -> a
<> Builder
", resolve the conflicts, then run "
                        forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit commit")
                        forall a. Semigroup a => a -> a -> a
<> Builder
" to synchronize "
                        forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Context
context.branch
                        forall a. Semigroup a => a -> a -> a
<> Builder
" with "
                        forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
upstream
                        forall a. Semigroup a => a -> a -> a
<> Builder
"."
                  ]
          GitPushWhat
TriedToPush -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream,
        -- Whether we say 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.
        if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null MitState ()
state.undos) Bool -> Bool -> Bool
&& Bool
committed then Stanza
canUndoStanza else forall a. Maybe a
Nothing
      ]

mitCommitMerge :: Mit Env x ()
mitCommitMerge :: forall x. Mit Env x ()
mitCommitMerge = do
  Context
context <- forall x. Mit Env x Context
getContext

  -- Make the merge commit. Commonly we'll have gotten here by `mit merge <branch>`, so we'll have a `state0.merging`
  -- that tells us we're merging in <branch>. But we also handle the case that we went `git merge` -> `mit commit`,
  -- because why not.
  case Context
context.state.merging of
    Maybe Text
Nothing -> forall x. [Text] -> Mit Env x ()
git_ [Text
"commit", Text
"--all", Text
"--no-edit"]
    Just Text
merging ->
      let message :: Text
message = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Text
"⅄ ", if Text
merging forall a. Eq a => a -> a -> Bool
== Context
context.branch then Text
"" else Text
merging forall a. Semigroup a => a -> a -> a
<> Text
" → ", Context
context.branch]
       in forall x. [Text] -> Mit Env x ()
git_ [Text
"commit", Text
"--all", Text
"--message", Text
message]

  forall x. Text -> MitState () -> Mit Env x ()
writeMitState Context
context.branch Context
context.state {$sel:merging:MitState :: Maybe Text
merging = forall a. Maybe a
Nothing}

  let stanza0 :: Stanza
stanza0 = do
        Text
merging <- Context
context.state.merging
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
merging forall a. Eq a => a -> a -> Bool
/= Context
context.branch)
        Text -> Text -> Stanza
synchronizedStanza Context
context.branch Text
merging

  -- Three possible cases:
  --   1. We had a dirty working directory before `mit merge` (evidence: our undo has a `git stash apply` in it)
  --     a. We can cleanly unstash it, so proceed to sync
  --     b. We cannot cleanly unstash it, so don't sync, because that may *further* conflict, and we don't want nasty
  --        double conflict markers
  --   2. We had a clean working directory before `mit merge`, so proceed to sync

  case [Undo] -> Maybe Text
undosStash Context
context.state.undos of
    Maybe Text
Nothing -> forall x. Stanza -> Maybe [Undo] -> Mit Env x ()
mitSyncWith Stanza
stanza0 (forall a. a -> Maybe a
Just [Text -> Undo
Reset (forall a. HasCallStack => Maybe a -> a
fromJust Context
context.snapshot).head])
    Just Text
stash -> do
      [GitConflict]
conflicts <- forall x. Text -> Mit Env x [GitConflict]
gitApplyStash Text
stash
      case forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitConflict]
conflicts of
        -- FIXME we just unstashed, now we're about to stash again :/
        Maybe (NonEmpty GitConflict)
Nothing -> forall x. Stanza -> Maybe [Undo] -> Mit Env x ()
mitSyncWith Stanza
stanza0 (forall a. a -> Maybe a
Just [Text -> Undo
Reset (forall a. HasCallStack => Maybe a -> a
fromJust Context
context.snapshot).head, Text -> Undo
Apply Text
stash])
        Just NonEmpty GitConflict
conflicts1 ->
          forall a r x. IO a -> Mit r x a
io do
            [Stanza] -> IO ()
putStanzas
              [ Stanza
stanza0,
                Builder -> NonEmpty GitConflict -> Stanza
conflictsStanza Builder
"These files are in conflict:" NonEmpty GitConflict
conflicts1,
                -- Fake like we didn't push due to merge conflicts just to print "resolve conflicts and commit"
                Text -> PushResult -> Stanza
whatNextStanza Context
context.branch (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
MergeConflicts),
                if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Context
context.state.undos then forall a. Maybe a
Nothing else Stanza
canUndoStanza
              ]

-- FIXME delete
data PushResult
  = PushAttempted Bool
  | PushNotAttempted PushNotAttemptedReason

data PushNotAttemptedReason
  = ForkedHistory [GitConflict] -- local history has forked, need to sync.
  | MergeConflicts -- local merge conflicts that need to be resolved right now
  | 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

mitMerge :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Text -> Mit Env xx ()
mitMerge :: forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Text -> Mit Env xx ()
mitMerge Goto Env x [Stanza]
return Text
target = do
  forall x. (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
dieIfMergeInProgress Goto Env x [Stanza]
return
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall x. Mit Env x Bool
gitExistUntrackedFiles (forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
dieIfBuggyGit @x Goto Env x [Stanza]
return)

  Context
context <- forall x. Mit Env x Context
getContext
  let upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Context
context.branch

  if Text
target forall a. Eq a => a -> a -> Bool
== Context
context.branch Bool -> Bool -> Bool
|| Text
target forall a. Eq a => a -> a -> Bool
== Text
upstream
    then -- If on branch `foo`, treat `mit merge foo` and `mit merge origin/foo` as `mit sync`
      forall x. Stanza -> Maybe [Undo] -> Mit Env x ()
mitSyncWith forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    else forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Context -> Text -> Mit Env xx ()
mitMergeWith @x Goto Env x [Stanza]
return Context
context Text
target

mitMergeWith :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Context -> Text -> Mit Env xx ()
mitMergeWith :: forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Context -> Text -> Mit Env xx ()
mitMergeWith Goto Env x [Stanza]
return Context
context Text
target = do
  -- When given 'mit merge foo', prefer running 'git merge origin/foo' over 'git merge foo'
  Text
targetCommit <-
    forall x. Text -> Text -> Mit Env x (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
target
      forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM
        ( forall x. Text -> Mit Env x (Maybe Text)
gitBranchHead Text
target
            forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM (Goto Env x [Stanza]
return [forall a. a -> Maybe a
Just (Builder -> Builder
Text.red Builder
"No such branch.")])
        )

  let upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Context
context.branch

  Bool
existRemoteCommits <- forall x. Context -> Mit Env x Bool
contextExistRemoteCommits Context
context
  Bool
existLocalCommits <- forall x. Context -> Mit Env x Bool
contextExistLocalCommits Context
context

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
existRemoteCommits Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
existLocalCommits) do
    Goto Env x [Stanza]
return
      [ Text -> Text -> Builder -> Stanza
notSynchronizedStanza Context
context.branch Text
upstream Builder
".",
        Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream
      ]

  forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Context -> Maybe Text
contextStash Context
context) \Text
_stash ->
    forall x. Command -> Mit Env x ()
Git.git_ (ResetMode -> FlagQuiet -> Text -> Command
Git.Reset ResetMode
Git.Hard FlagQuiet
Git.FlagQuiet Text
"HEAD")

  GitMerge
merge <- forall x. Text -> Text -> Mit Env x GitMerge
performMerge (Text
"⅄ " forall a. Semigroup a => a -> a -> a
<> Text
target forall a. Semigroup a => a -> a -> a
<> Text
" → " forall a. Semigroup a => a -> a -> a
<> Context
context.branch) Text
targetCommit

  [GitConflict]
stashConflicts <-
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts
      then case Context -> Maybe Text
contextStash Context
context of
        Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Just Text
stash -> forall x. Text -> Mit Env x [GitConflict]
gitApplyStash Text
stash
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  GitPush
push <- forall x. Text -> Mit Env x GitPush
performPush Context
context.branch

  let state :: MitState ()
state =
        MitState
          { $sel:head:MitState :: ()
head = (),
            $sel:merging:MitState :: Maybe Text
merging =
              if forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts
                then forall a. Maybe a
Nothing
                else forall a. a -> Maybe a
Just Text
target,
            $sel:undos:MitState :: [Undo]
undos =
              if GitPush -> Bool
pushPushed GitPush
push Bool -> Bool -> Bool
|| forall a. Seq a -> Bool
Seq.null GitMerge
merge.commits
                then []
                else case Context
context.snapshot of
                  Maybe GitSnapshot
Nothing -> []
                  Just GitSnapshot
snapshot -> GitSnapshot -> [Undo]
undoToSnapshot GitSnapshot
snapshot
          }

  forall x. Text -> MitState () -> Mit Env x ()
writeMitState Context
context.branch MitState ()
state

  Seq GitCommitInfo
remoteCommits <-
    case Context
context.upstreamHead of
      Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Seq a
Seq.empty
      Just Text
upstreamHead -> forall x. Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo)
gitCommitsBetween (forall a. a -> Maybe a
Just Text
"HEAD") Text
upstreamHead

  [GitConflict]
conflictsOnSync <-
    if forall a. Seq a -> Bool
Seq.null Seq GitCommitInfo
remoteCommits
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else forall x. Text -> Mit Env x [GitConflict]
gitConflictsWith (forall a. HasCallStack => Maybe a -> a
fromJust Context
context.upstreamHead)

  forall a r x. IO a -> Mit r x a
io do
    [Stanza] -> IO ()
putStanzas
      [ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts
          then Text -> Text -> Stanza
synchronizedStanza Context
context.branch Text
target
          else Text -> Text -> Builder -> Stanza
notSynchronizedStanza Context
context.branch Text
target Builder
".",
        do
          Seq1 GitCommitInfo
commits1 <- forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq GitMerge
merge.commits
          Sync -> Stanza
syncStanza
            Sync
              { $sel:commits:Sync :: Seq1 GitCommitInfo
commits = Seq1 GitCommitInfo
commits1,
                $sel:success:Sync :: Bool
success = forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts,
                $sel:source:Sync :: Text
source = Text
target,
                $sel:target:Sync :: Text
target = Context
context.branch
              },
        Text -> GitPushWhat -> Stanza
isSynchronizedStanza2 Context
context.branch GitPush
push.what,
        do
          Seq1 GitCommitInfo
commits <- forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq Seq GitCommitInfo
remoteCommits
          Sync -> Stanza
syncStanza Sync {Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
$sel:commits:Sync :: Seq1 GitCommitInfo
commits, $sel:success:Sync :: Bool
success = Bool
False, $sel:source:Sync :: Text
source = Text
upstream, $sel:target:Sync :: Text
target = Context
context.branch},
        -- TODO show commits to remote
        do
          NonEmpty GitConflict
conflicts1 <- forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty GitMerge
merge.conflicts forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitConflict]
stashConflicts
          Builder -> NonEmpty GitConflict -> Stanza
conflictsStanza Builder
"These files are in conflict:" NonEmpty GitConflict
conflicts1,
        -- TODO audit this
        case GitPush
push.what of
          GitPushWhat
NothingToPush2 -> forall a. Maybe a
Nothing
          GitPushWhat
Pushed -> forall a. Maybe a
Nothing
          GitPushWhat
PushWouldntReachRemote -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"When you come online, run" Context
context.branch Text
upstream
          -- FIXME hrm, but we might have merge conflicts and/or stash conflicts!
          GitPushWhat
PushWouldBeRejected ->
            case forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitConflict]
conflictsOnSync of
              Maybe (NonEmpty GitConflict)
Nothing -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream
              Just NonEmpty GitConflict
conflictsOnSync1 ->
                [Stanza] -> Stanza
renderStanzas
                  [ Builder -> NonEmpty GitConflict -> Stanza
conflictsStanza
                      ( Builder
"These files will be in conflict when you run "
                          forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit sync")
                          forall a. Semigroup a => a -> a -> a
<> Builder
":"
                      )
                      NonEmpty GitConflict
conflictsOnSync1,
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                      Builder
"  Run "
                        forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit sync")
                        forall a. Semigroup a => a -> a -> a
<> Builder
", resolve the conflicts, then run "
                        forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit commit")
                        forall a. Semigroup a => a -> a -> a
<> Builder
" to synchronize "
                        forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Context
context.branch
                        forall a. Semigroup a => a -> a -> a
<> Builder
" with "
                        forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
upstream
                        forall a. Semigroup a => a -> a -> a
<> Builder
"."
                  ]
          GitPushWhat
TriedToPush -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream,
        if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null MitState ()
state.undos) then Stanza
canUndoStanza else forall a. Maybe a
Nothing
      ]

-- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream
mitSync :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()
mitSync :: forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitSync Goto Env x [Stanza]
return = do
  forall x. (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()
dieIfMergeInProgress Goto Env x [Stanza]
return
  forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall x. Mit Env x Bool
gitExistUntrackedFiles (forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
dieIfBuggyGit @x Goto Env x [Stanza]
return)
  forall x. Stanza -> Maybe [Undo] -> Mit Env x ()
mitSyncWith forall a. Maybe a
Nothing 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 :: Stanza -> Maybe [Undo] -> Mit Env x ()
mitSyncWith :: forall x. Stanza -> Maybe [Undo] -> Mit Env x ()
mitSyncWith Stanza
stanza0 Maybe [Undo]
maybeUndos = do
  Context
context <- forall x. Mit Env x Context
getContext
  let upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Context
context.branch

  forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Context -> Maybe Text
contextStash Context
context) \Text
_stash ->
    forall x. Command -> Mit Env x ()
Git.git_ (ResetMode -> FlagQuiet -> Text -> Command
Git.Reset ResetMode
Git.Hard FlagQuiet
Git.FlagQuiet Text
"HEAD")

  GitMerge
merge <-
    case Context
context.upstreamHead of
      -- Yay: no upstream branch is not different from an up-to-date local branch
      Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GitMerge {$sel:commits:GitMerge :: Seq GitCommitInfo
commits = forall a. Seq a
Seq.empty, $sel:conflicts:GitMerge :: [GitConflict]
conflicts = []}
      Just Text
upstreamHead -> forall x. Text -> Text -> Mit Env x GitMerge
performMerge (Text
"⅄ " forall a. Semigroup a => a -> a -> a
<> Context
context.branch) Text
upstreamHead

  [GitConflict]
stashConflicts <-
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts
      then case Context -> Maybe Text
contextStash Context
context of
        Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Just Text
stash -> forall x. Text -> Mit Env x [GitConflict]
gitApplyStash Text
stash
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  GitPush
push <- forall x. Text -> Mit Env x GitPush
performPush Context
context.branch

  let state :: MitState ()
state =
        MitState
          { $sel:head:MitState :: ()
head = (),
            $sel:merging:MitState :: Maybe Text
merging =
              if forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts
                then forall a. Maybe a
Nothing
                else forall a. a -> Maybe a
Just Context
context.branch,
            $sel:undos:MitState :: [Undo]
undos =
              if GitPush -> Bool
pushPushed GitPush
push
                then []
                else case Maybe [Undo]
maybeUndos of
                  Maybe [Undo]
Nothing ->
                    if forall a. Seq a -> Bool
Seq.null GitMerge
merge.commits
                      then []
                      else case Context
context.snapshot of
                        Maybe GitSnapshot
Nothing -> []
                        Just GitSnapshot
snapshot -> GitSnapshot -> [Undo]
undoToSnapshot GitSnapshot
snapshot
                  -- FIXME hm, could consider appending those undos instead, even if they obviate the recent stash/merge
                  -- undos
                  Just [Undo]
undos' -> [Undo]
undos'
          }

  forall x. Text -> MitState () -> Mit Env x ()
writeMitState Context
context.branch MitState ()
state

  forall a r x. IO a -> Mit r x a
io do
    [Stanza] -> IO ()
putStanzas
      [ Stanza
stanza0,
        Text -> GitPushWhat -> Stanza
isSynchronizedStanza2 Context
context.branch GitPush
push.what,
        do
          Seq1 GitCommitInfo
commits1 <- forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq GitMerge
merge.commits
          Sync -> Stanza
syncStanza
            Sync
              { $sel:commits:Sync :: Seq1 GitCommitInfo
commits = Seq1 GitCommitInfo
commits1,
                $sel:success:Sync :: Bool
success = forall (t :: * -> *) a. Foldable t => t a -> Bool
null GitMerge
merge.conflicts,
                $sel:source:Sync :: Text
source = Text
upstream,
                $sel:target:Sync :: Text
target = Context
context.branch
              },
        do
          Seq1 GitCommitInfo
commits <- forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq GitPush
push.commits
          Sync -> Stanza
syncStanza
            Sync
              { Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
$sel:commits:Sync :: Seq1 GitCommitInfo
commits,
                $sel:success:Sync :: Bool
success = GitPush -> Bool
pushPushed GitPush
push,
                $sel:source:Sync :: Text
source = Context
context.branch,
                $sel:target:Sync :: Text
target = Text
upstream
              },
        do
          NonEmpty GitConflict
conflicts1 <- forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty GitMerge
merge.conflicts forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitConflict]
stashConflicts
          Builder -> NonEmpty GitConflict -> Stanza
conflictsStanza Builder
"These files are in conflict:" NonEmpty GitConflict
conflicts1,
        case GitPush
push.what of
          GitPushWhat
NothingToPush2 -> forall a. Maybe a
Nothing
          GitPushWhat
Pushed -> forall a. Maybe a
Nothing
          GitPushWhat
PushWouldntReachRemote -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"When you come online, run" Context
context.branch Text
upstream
          GitPushWhat
PushWouldBeRejected ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
              Builder
"  Resolve the conflicts, then run "
                forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit commit")
                forall a. Semigroup a => a -> a -> a
<> Builder
" to synchronize "
                forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Context
context.branch
                forall a. Semigroup a => a -> a -> a
<> Builder
" with "
                forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
upstream
                forall a. Semigroup a => a -> a -> a
<> Builder
"."
          GitPushWhat
TriedToPush -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Context
context.branch Text
upstream,
        if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null MitState ()
state.undos) then Stanza
canUndoStanza else forall a. Maybe a
Nothing
      ]

-- FIXME output what we just undid
mitUndo :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()
mitUndo :: forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitUndo Goto Env x [Stanza]
return = do
  Context
context <- forall x. Mit Env x Context
getContext
  case forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty Context
context.state.undos of
    Maybe (NonEmpty Undo)
Nothing -> Goto Env x [Stanza]
return [forall a. a -> Maybe a
Just (Builder -> Builder
Text.red Builder
"Nothing to undo.")]
    Just NonEmpty Undo
undos1 -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty Undo
undos1 forall x. Undo -> Mit Env x ()
applyUndo
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Undo] -> Bool
undosContainRevert Context
context.state.undos) (forall x xx.
Label (X x [Stanza]) xx =>
Goto Env x [Stanza] -> Mit Env xx ()
mitSync @x Goto Env x [Stanza]
return)
  where
    undosContainRevert :: [Undo] -> Bool
    undosContainRevert :: [Undo] -> Bool
undosContainRevert = \case
      [] -> Bool
False
      Revert Text
_ : [Undo]
_ -> Bool
True
      Undo
_ : [Undo]
undos -> [Undo] -> Bool
undosContainRevert [Undo]
undos

-- FIXME this type kinda sux now, replace with GitMerge probably?
data Sync = Sync
  { Sync -> Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo,
    Sync -> Bool
success :: Bool,
    Sync -> Text
source :: Text,
    Sync -> Text
target :: Text
  }

canUndoStanza :: Stanza
canUndoStanza :: Stanza
canUndoStanza =
  forall a. a -> Maybe a
Just (Builder
"  Run " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit undo") forall a. Semigroup a => a -> a -> a
<> Builder
" to undo this change.")

conflictsStanza :: Text.Builder -> List1 GitConflict -> Stanza
conflictsStanza :: Builder -> NonEmpty GitConflict -> Stanza
conflictsStanza Builder
prefix NonEmpty GitConflict
conflicts =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    Builder
"  "
      forall a. Semigroup a => a -> a -> a
<> Builder
prefix
      forall a. Semigroup a => a -> a -> a
<> Builder
Builder.newline
      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *). Foldable f => f Builder -> Builder
Builder.vcat ((\GitConflict
conflict -> Builder
"    " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.red (GitConflict -> Builder
showGitConflict GitConflict
conflict)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty GitConflict
conflicts)

isSynchronizedStanza2 :: Text -> GitPushWhat -> Stanza
isSynchronizedStanza2 :: Text -> GitPushWhat -> Stanza
isSynchronizedStanza2 Text
branch = \case
  GitPushWhat
NothingToPush2 -> Text -> Text -> Stanza
synchronizedStanza Text
branch Text
upstream
  GitPushWhat
Pushed -> Text -> Text -> Stanza
synchronizedStanza Text
branch Text
upstream
  GitPushWhat
PushWouldntReachRemote -> Text -> Text -> Builder -> Stanza
notSynchronizedStanza Text
branch Text
upstream Builder
" because you appear to be offline."
  GitPushWhat
PushWouldBeRejected -> Text -> Text -> Builder -> Stanza
notSynchronizedStanza Text
branch Text
upstream Builder
"; their histories have diverged."
  GitPushWhat
TriedToPush -> Text -> Text -> Builder -> Stanza
notSynchronizedStanza Text
branch Text
upstream (Builder
" because " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold Builder
"git push" forall a. Semigroup a => a -> a -> a
<> Builder
" failed.")
  where
    upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Text
branch

notSynchronizedStanza :: Text -> Text -> Text.Builder -> Stanza
notSynchronizedStanza :: Text -> Text -> Builder -> Stanza
notSynchronizedStanza Text
branch Text
other Builder
suffix =
  forall a. a -> Maybe a
Just (Builder
"  " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.red (Text -> Builder
branchb Text
branch forall a. Semigroup a => a -> a -> a
<> Builder
" is not synchronized with " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
other forall a. Semigroup a => a -> a -> a
<> Builder
suffix))

runSyncStanza :: Text.Builder -> Text -> Text -> Stanza
runSyncStanza :: Builder -> Text -> Text -> Stanza
runSyncStanza Builder
prefix Text
branch Text
upstream =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    Builder
"  "
      forall a. Semigroup a => a -> a -> a
<> Builder
prefix
      forall a. Semigroup a => a -> a -> a
<> Builder
" "
      forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit sync")
      forall a. Semigroup a => a -> a -> a
<> Builder
" to synchronize "
      forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
branch
      forall a. Semigroup a => a -> a -> a
<> Builder
" with "
      forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
upstream
      forall a. Semigroup a => a -> a -> a
<> Builder
"."

syncStanza :: Sync -> Stanza
syncStanza :: Sync -> Stanza
syncStanza Sync
sync =
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    Builder -> Builder
Text.italic
      (Builder -> Builder
colorize (Builder
"    " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.fromText Sync
sync.source forall a. Semigroup a => a -> a -> a
<> Builder
" → " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.fromText Sync
sync.target))
      forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
      forall a. Semigroup a => a -> a -> a
<> (forall (f :: * -> *). Foldable f => f Builder -> Builder
Builder.vcat ((\GitCommitInfo
commit -> Builder
"    " forall a. Semigroup a => a -> a -> a
<> GitCommitInfo -> Builder
prettyGitCommitInfo GitCommitInfo
commit) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq GitCommitInfo
commits'))
      forall a. Semigroup a => a -> a -> a
<> (if Bool
more then Builder
"    ..." else Builder
Builder.empty)
  where
    colorize :: Text.Builder -> Text.Builder
    colorize :: Builder -> Builder
colorize =
      if Sync
sync.success then Builder -> Builder
Text.green else Builder -> Builder
Text.red
    (Seq GitCommitInfo
commits', Bool
more) =
      case forall a. Seq1 a -> Int
Seq1.length Sync
sync.commits forall a. Ord a => a -> a -> Bool
> Int
10 of
        Bool
False -> (forall a. Seq1 a -> Seq a
Seq1.toSeq Sync
sync.commits, Bool
False)
        Bool
True -> (forall a. Int -> Seq1 a -> Seq a
Seq1.dropEnd Int
1 Sync
sync.commits, Bool
True)

synchronizedStanza :: Text -> Text -> Stanza
synchronizedStanza :: Text -> Text -> Stanza
synchronizedStanza Text
branch Text
other =
  forall a. a -> Maybe a
Just (Builder
"  " forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
Text.green (Text -> Builder
branchb Text
branch forall a. Semigroup a => a -> a -> a
<> Builder
" is synchronized with " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
other forall a. Semigroup a => a -> a -> a
<> Builder
"."))

-- FIXME remove
whatNextStanza :: Text -> PushResult -> Stanza
whatNextStanza :: Text -> PushResult -> Stanza
whatNextStanza Text
branch = \case
  PushAttempted Bool
False -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Run" Text
branch Text
upstream
  PushAttempted Bool
True -> forall a. Maybe a
Nothing
  PushNotAttempted (ForkedHistory [GitConflict]
conflicts) ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GitConflict]
conflicts
        then
          Builder
"  Run "
            forall a. Semigroup a => a -> a -> a
<> Builder
sync
            forall a. Semigroup a => a -> a -> a
<> Builder
", examine the repository, then run "
            forall a. Semigroup a => a -> a -> a
<> Builder
sync
            forall a. Semigroup a => a -> a -> a
<> Builder
" again to synchronize "
            forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
branch
            forall a. Semigroup a => a -> a -> a
<> Builder
" with "
            forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
upstream
            forall a. Semigroup a => a -> a -> a
<> Builder
"."
        else
          Builder
"  Run "
            forall a. Semigroup a => a -> a -> a
<> Builder
sync
            forall a. Semigroup a => a -> a -> a
<> Builder
", resolve the conflicts, then run "
            forall a. Semigroup a => a -> a -> a
<> Builder
commit
            forall a. Semigroup a => a -> a -> a
<> Builder
" to synchronize "
            forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
branch
            forall a. Semigroup a => a -> a -> a
<> Builder
" with "
            forall a. Semigroup a => a -> a -> a
<> Text -> Builder
branchb Text
upstream
            forall a. Semigroup a => a -> a -> a
<> Builder
"."
  PushNotAttempted PushNotAttemptedReason
MergeConflicts ->
    forall a. a -> Maybe a
Just (Builder
"  Resolve the merge conflicts, then run " forall a. Semigroup a => a -> a -> a
<> Builder
commit forall a. Semigroup a => a -> a -> a
<> Builder
".")
  PushNotAttempted PushNotAttemptedReason
NothingToPush -> forall a. Maybe a
Nothing
  PushNotAttempted PushNotAttemptedReason
Offline -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"When you come online, run" Text
branch Text
upstream
  PushNotAttempted PushNotAttemptedReason
UnseenCommits -> Builder -> Text -> Text -> Stanza
runSyncStanza Builder
"Examine the repository, then run" Text
branch Text
upstream
  where
    commit :: Builder
commit = Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit commit")
    sync :: Builder
sync = Builder -> Builder
Text.bold (Builder -> Builder
Text.blue Builder
"mit sync")
    upstream :: Text
upstream = Text
"origin/" forall a. Semigroup a => a -> a -> a
<> Text
branch

branchb :: Text -> Text.Builder
branchb :: Text -> Builder
branchb =
  Builder -> Builder
Text.italic forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
Text.Builder.fromText

------------------------------------------------------------------------------------------------------------------------
-- Context

data Context = Context
  { Context -> Text
branch :: Text,
    Context -> Maybe GitSnapshot
snapshot :: Maybe GitSnapshot, -- Nothing when no commits yet
    Context -> MitState ()
state :: MitState (),
    Context -> Maybe Text
upstreamHead :: Maybe Text
  }

getContext :: Mit Env x Context
getContext :: forall x. Mit Env x Context
getContext = do
  forall x. Text -> Mit Env x ()
gitFetch_ Text
"origin"
  Text
branch <- forall a x. ProcessOutput a => Command -> Mit Env x a
Git.git Command
Git.BranchShowCurrent
  Maybe Text
upstreamHead <- forall x. Text -> Text -> Mit Env x (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
branch
  MitState ()
state <- forall x. Text -> Mit Env x (MitState ())
readMitState Text
branch
  Maybe GitSnapshot
snapshot <- forall x. Mit Env x (Maybe GitSnapshot)
performSnapshot
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Context {Text
branch :: Text
$sel:branch:Context :: Text
branch, Maybe GitSnapshot
snapshot :: Maybe GitSnapshot
$sel:snapshot:Context :: Maybe GitSnapshot
snapshot, MitState ()
state :: MitState ()
$sel:state:Context :: MitState ()
state, Maybe Text
upstreamHead :: Maybe Text
$sel:upstreamHead:Context :: Maybe Text
upstreamHead}

contextExistLocalCommits :: Context -> Mit Env x Bool
contextExistLocalCommits :: forall x. Context -> Mit Env x Bool
contextExistLocalCommits Context
context =
  case Context
context.upstreamHead of
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just Text
upstreamHead ->
      case Context
context.snapshot of
        Maybe GitSnapshot
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Just GitSnapshot
snapshot -> forall x. Text -> Text -> Mit Env x Bool
gitExistCommitsBetween Text
upstreamHead GitSnapshot
snapshot.head

contextExistRemoteCommits :: Context -> Mit Env x Bool
contextExistRemoteCommits :: forall x. Context -> Mit Env x Bool
contextExistRemoteCommits Context
context =
  case Context
context.upstreamHead of
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Text
upstreamHead ->
      case Context
context.snapshot of
        Maybe GitSnapshot
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just GitSnapshot
snapshot -> forall x. Text -> Text -> Mit Env x Bool
gitExistCommitsBetween GitSnapshot
snapshot.head Text
upstreamHead

contextStash :: Context -> Maybe Text
contextStash :: Context -> Maybe Text
contextStash Context
context = do
  GitSnapshot
snapshot <- Context
context.snapshot
  GitSnapshot
snapshot.stash

------------------------------------------------------------------------------------------------------------------------
-- Git merge

-- | The result of a @git merge@.
--
-- Impossible case: Impossible case: empty list of commits, non-empty list of conflicts.
data GitMerge = GitMerge
  { -- | The list of commits that were applied (or would be applied once conflicts are resolved), minus the merge commit
    -- itself.
    GitMerge -> Seq GitCommitInfo
commits :: Seq GitCommitInfo,
    GitMerge -> [GitConflict]
conflicts :: [GitConflict]
  }

-- Perform a fast-forward-if-possible git merge, and return the commits that were applied (or *would be* applied) (minus
-- the merge commit), along with the conflicting files. Impossible case: empty list of commits, non-empty list of
-- conflicts.
--
-- Precondition: the working directory is clean. TODO take unused GitStash as argument?
performMerge :: Text -> Text -> Mit Env x GitMerge
performMerge :: forall x. Text -> Text -> Mit Env x GitMerge
performMerge Text
message Text
commitish = do
  Text
head <- forall x. Mit Env x Text
gitHead
  Seq GitCommitInfo
commits <- forall x. Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo)
gitCommitsBetween (forall a. a -> Maybe a
Just Text
head) Text
commitish
  [GitConflict]
conflicts <-
    if forall a. Seq a -> Bool
Seq.null Seq GitCommitInfo
commits
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else
        forall a x. ProcessOutput a => [Text] -> Mit Env x a
git [Text
"merge", Text
"--ff", Text
"--no-commit", Text
commitish] 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 -> do
            -- If this was a fast-forward, a merge would not be in progress at this point.
            forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall x. Mit Env x Bool
gitMergeInProgress (forall x. [Text] -> Mit Env x ()
git_ [Text
"commit", Text
"--message", Text
message])
            forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GitMerge {Seq GitCommitInfo
commits :: Seq GitCommitInfo
$sel:commits:GitMerge :: Seq GitCommitInfo
commits, [GitConflict]
conflicts :: [GitConflict]
$sel:conflicts:GitMerge :: [GitConflict]
conflicts}

------------------------------------------------------------------------------------------------------------------------
-- Git push

data GitPush = GitPush
  { GitPush -> Seq GitCommitInfo
commits :: Seq GitCommitInfo,
    GitPush -> [Undo]
undo :: [Undo],
    GitPush -> GitPushWhat
what :: GitPushWhat
  }

data GitPushWhat
  = NothingToPush2
  | Pushed
  | PushWouldntReachRemote
  | PushWouldBeRejected
  | TriedToPush

pushPushed :: GitPush -> Bool
pushPushed :: GitPush -> Bool
pushPushed GitPush
push =
  case GitPush
push.what of
    GitPushWhat
NothingToPush2 -> Bool
False
    GitPushWhat
Pushed -> Bool
True
    GitPushWhat
PushWouldntReachRemote -> Bool
False
    GitPushWhat
PushWouldBeRejected -> Bool
False
    GitPushWhat
TriedToPush -> Bool
False

-- TODO get context
performPush :: Text -> Mit Env x GitPush
performPush :: forall x. Text -> Mit Env x GitPush
performPush Text
branch = do
  Bool
fetched <- forall x. Text -> Mit Env x Bool
gitFetch Text
"origin"
  Text
head <- forall x. Mit Env x Text
gitHead
  Maybe Text
upstreamHead <- forall x. Text -> Text -> Mit Env x (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
branch
  Seq GitCommitInfo
commits <- forall x. Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo)
gitCommitsBetween Maybe Text
upstreamHead Text
head

  if forall a. Seq a -> Bool
Seq.null Seq GitCommitInfo
commits
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure GitPush {Seq GitCommitInfo
commits :: Seq GitCommitInfo
$sel:commits:GitPush :: Seq GitCommitInfo
commits, $sel:undo:GitPush :: [Undo]
undo = [], $sel:what:GitPush :: GitPushWhat
what = GitPushWhat
NothingToPush2}
    else do
      Bool
existRemoteCommits <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (forall x. Text -> Text -> Mit Env x Bool
gitExistCommitsBetween Text
head) Maybe Text
upstreamHead
      if Bool
existRemoteCommits
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure GitPush {Seq GitCommitInfo
commits :: Seq GitCommitInfo
$sel:commits:GitPush :: Seq GitCommitInfo
commits, $sel:undo:GitPush :: [Undo]
undo = [], $sel:what:GitPush :: GitPushWhat
what = GitPushWhat
PushWouldBeRejected}
        else
          if Bool
fetched
            then
              forall x. Text -> Mit Env x Bool
gitPush Text
branch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GitPush {Seq GitCommitInfo
commits :: Seq GitCommitInfo
$sel:commits:GitPush :: Seq GitCommitInfo
commits, $sel:undo:GitPush :: [Undo]
undo = [], $sel:what:GitPush :: GitPushWhat
what = GitPushWhat
TriedToPush}
                Bool
True -> do
                  [Undo]
undo <-
                    if forall a. Seq a -> Int
Seq.length Seq GitCommitInfo
commits forall a. Eq a => a -> a -> Bool
== Int
1
                      then
                        forall x. Text -> Mit Env x Bool
gitIsMergeCommit Text
head forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                          Bool
False -> [Text -> Undo
Revert Text
head]
                          Bool
True -> []
                      else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure GitPush {Seq GitCommitInfo
commits :: Seq GitCommitInfo
$sel:commits:GitPush :: Seq GitCommitInfo
commits, [Undo]
undo :: [Undo]
$sel:undo:GitPush :: [Undo]
undo, $sel:what:GitPush :: GitPushWhat
what = GitPushWhat
Pushed}
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure GitPush {Seq GitCommitInfo
commits :: Seq GitCommitInfo
$sel:commits:GitPush :: Seq GitCommitInfo
commits, $sel:undo:GitPush :: [Undo]
undo = [], $sel:what:GitPush :: GitPushWhat
what = GitPushWhat
PushWouldntReachRemote}

------------------------------------------------------------------------------------------------------------------------
-- Git snapshot

data GitSnapshot = GitSnapshot
  { GitSnapshot -> Text
head :: Text,
    GitSnapshot -> Maybe Text
stash :: Maybe Text
  }

performSnapshot :: Mit Env x (Maybe GitSnapshot)
performSnapshot :: forall x. Mit Env x (Maybe GitSnapshot)
performSnapshot = do
  forall x. Mit Env x (Maybe Text)
gitMaybeHead forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just Text
head -> do
      Maybe Text
stash <-
        forall x. Mit Env x DiffResult
gitDiff forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          DiffResult
Differences -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. Mit Env x Text
gitCreateStash
          DiffResult
NoDifferences -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just GitSnapshot {Text
head :: Text
$sel:head:GitSnapshot :: Text
head, Maybe Text
stash :: Maybe Text
$sel:stash:GitSnapshot :: Maybe Text
stash})

undoToSnapshot :: GitSnapshot -> [Undo]
undoToSnapshot :: GitSnapshot -> [Undo]
undoToSnapshot GitSnapshot
snapshot =
  Text -> Undo
Reset GitSnapshot
snapshot.head forall a. a -> [a] -> [a]
: case GitSnapshot
snapshot.stash of
    Maybe Text
Nothing -> []
    Just Text
stash -> [Text -> Undo
Apply Text
stash]