diff --git a/mit-3qvpPyAi6mH.cabal b/mit-3qvpPyAi6mH.cabal --- a/mit-3qvpPyAi6mH.cabal +++ b/mit-3qvpPyAi6mH.cabal @@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX -version: 11 +version: 12 description: A git wrapper with a streamlined UX. @@ -31,6 +31,7 @@ common component default-extensions: BlockArguments + ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass @@ -43,7 +44,9 @@ GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase + ImplicitParams ImportQualifiedPost + InstanceSigs MultiParamTypeClasses MultiWayIf NamedFieldPuns @@ -67,38 +70,52 @@ -Wno-all-missed-specialisations -Wno-missing-import-lists -Wno-missing-kind-signatures + -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-unsafe library import: component build-depends: - base ^>= 4.16 || ^>= 4.17, + base == 4.19.1.0, base64 == 0.4.2.4, - containers == 0.6.6, - directory == 1.3.7.1, - ki == 1.0.0.1, + containers == 0.6.8, + directory == 1.3.8.1, + ki == 1.0.1.1, optparse-applicative == 0.17.0.0, - parsec == 3.1.15.1, - process == 1.6.15.0, - stm == 2.5.1.0, - text == 2.0.1, - text-ansi == 0.1.1, - unix == 2.7.3, + parsec == 3.1.17.0, + process == 1.6.18.0, + stm == 2.5.2.1, + text == 2.1, + text-ansi == 0.3.0.1, + text-builder-linear == 0.1.2, + unconditional-jump == 1.0.0, + unix == 2.8.3.0, exposed-modules: Mit - Mit.Builder + Mit.Command.Branch + Mit.Command.Commit + Mit.Command.Merge + Mit.Command.Status + Mit.Command.Sync + Mit.Command.Undo Mit.Directory - Mit.Env Mit.Git - Mit.Monad + Mit.Logger + Mit.Merge + Mit.Output Mit.Prelude + Mit.Pretty Mit.Process + Mit.ProcessInfo + Mit.Push Mit.Seq Mit.Seq1 - Mit.Stanza + Mit.Snapshot Mit.State + Mit.TextUtils Mit.Undo + Mit.Verbosity hs-source-dirs: src executable mit diff --git a/src/Mit.hs b/src/Mit.hs --- a/src/Mit.hs +++ b/src/Mit.hs @@ -4,850 +4,497 @@ where import Control.Applicative (many) -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.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 = do - (verbosity, command) <- Opt.customExecParser parserPrefs parserInfo - - let action :: Mit Env [Stanza] - action = do - gitRevParseAbsoluteGitDir >>= \case - False -> pure [Just (Text.red "The current directory doesn't contain a git repository.")] - True -> do - label \return -> do - case command of - MitCommand'Branch branch -> mitBranch return branch $> [] - MitCommand'Commit -> mitCommit return $> [] - MitCommand'Merge branch -> mitMerge return branch $> [] - MitCommand'Sync -> mitSync return $> [] - MitCommand'Undo -> mitUndo return $> [] - - runMit Env {verbosity} action >>= \case - [] -> pure () - errs -> do - putStanzas errs - exitFailure - where - parserPrefs :: Opt.ParserPrefs - parserPrefs = - Opt.ParserPrefs - { prefBacktrack = Opt.Backtrack, - prefColumns = 80, - prefDisambiguate = True, - prefHelpLongEquals = False, - prefHelpShowGlobal = True, - prefMultiSuffix = "+", - prefShowHelpOnEmpty = True, - prefShowHelpOnError = True, - prefTabulateFill = 24 -- grabbed this from optparse-applicative - } - - parserInfo :: Opt.ParserInfo (Int, MitCommand) - parserInfo = - Opt.info parser $ - Opt.progDesc "mit: a git wrapper with a streamlined UX" - - parser :: Opt.Parser (Int, MitCommand) - parser = - (,) - <$> (clamp (0, 2) . length <$> many (Opt.flag' () (Opt.help "Verbose (-v or -vv)" <> Opt.short 'v'))) - <*> (Opt.hsubparser . fold) - [ Opt.command "branch" $ - Opt.info - (MitCommand'Branch <$> Opt.strArgument (Opt.metavar "≪branch≫")) - (Opt.progDesc "Create a new branch in a new worktree."), - Opt.command "commit" $ - Opt.info - (pure MitCommand'Commit) - (Opt.progDesc "Create a commit interactively."), - Opt.command "merge" $ - Opt.info - (MitCommand'Merge <$> Opt.strArgument (Opt.metavar "≪branch≫")) - (Opt.progDesc "Merge the given branch into the current branch."), - Opt.command "sync" $ - Opt.info - (pure MitCommand'Sync) - (Opt.progDesc "Sync with the remote named `origin`."), - Opt.command "undo" $ - Opt.info - (pure MitCommand'Undo) - (Opt.progDesc "Undo the last `mit` command (if possible).") - ] - -data MitCommand - = MitCommand'Branch Text - | MitCommand'Commit - | MitCommand'Merge Text - | MitCommand'Sync - | MitCommand'Undo - -dieIfBuggyGit :: Goto Env [Stanza] -> Mit Env () -dieIfBuggyGit return = do - version <- gitVersion return - let validate (ver, err) = if version < ver then ((ver, err) :) else id - case foldr validate [] validations of - [] -> pure () - errors -> - return $ - map - ( \(ver, err) -> - Just - ( Text.red - ( "Prior to " <> Text.bold "git" <> " version " - <> Text.Builder.fromText (showGitVersion ver) - <> ", " - <> err - ) - ) - ) - errors - where - validations :: [(GitVersion, Text.Builder)] - validations = - [ ( GitVersion 2 29 0, - Text.bold "git commit --patch" - <> " was broken for new files added with " - <> Text.bold "git add --intent-to-add" - <> "." - ), - ( GitVersion 2 30 1, - Text.bold "git stash create" - <> " was broken for new files added with " - <> Text.bold "git add --intent-to-add" - <> "." - ) - ] - -dieIfMergeInProgress :: Goto Env [Stanza] -> Mit Env () -dieIfMergeInProgress return = - whenM gitMergeInProgress (return [Just (Text.red (Text.bold "git merge" <> " in progress."))]) - -mitBranch :: Goto Env [Stanza] -> Text -> Mit Env () -mitBranch return branch = do - worktreeDir <- do - rootdir <- git ["rev-parse", "--show-toplevel"] - pure (Text.dropWhileEnd (/= '/') rootdir <> branch) - - gitBranchWorktreeDir branch >>= \case - Nothing -> do - whenM (doesDirectoryExist worktreeDir) do - return [Just (Text.red ("Directory " <> Text.bold (Text.Builder.fromText worktreeDir) <> " already exists."))] - git_ ["worktree", "add", "--detach", worktreeDir] - cd worktreeDir do - whenNotM (git ["switch", branch]) do - git_ ["branch", "--no-track", branch] - git_ ["switch", branch] - gitFetch_ "origin" - whenM (gitRemoteBranchExists "origin" branch) do - let upstream = "origin/" <> branch - git_ ["reset", "--hard", "--quiet", upstream] - git_ ["branch", "--set-upstream-to", upstream] - Just directory -> - when (directory /= worktreeDir) do - return - [ Just - ( Text.red - ( Text.bold - ( Text.Builder.fromText branch - <> " is already checked out in " - <> Text.bold (Text.Builder.fromText directory) - ) - <> "." - ) - ) - ] - -mitCommit :: Goto Env [Stanza] -> Mit Env () -mitCommit return = do - whenM gitExistUntrackedFiles (dieIfBuggyGit return) - - gitMergeInProgress >>= \case - False -> - gitDiff >>= \case - Differences -> mitCommit_ return - NoDifferences -> return [Just (Text.red "There's nothing to commit.")] - True -> mitCommitMerge - -mitCommit_ :: Goto Env [Stanza] -> Mit Env () -mitCommit_ return = do - context <- getContext - let upstream = contextUpstream context - - existRemoteCommits <- contextExistRemoteCommits context - existLocalCommits <- contextExistLocalCommits context - - when (existRemoteCommits && not existLocalCommits) do - return - [ notSynchronizedStanza context.branch upstream ".", - runSyncStanza "Run" context.branch upstream - ] - - committed <- gitCommit - - push <- performPush context.branch - undoPush <- - case push of - Pushed commits -> - case Seq1.toList commits of - [commit] -> - gitIsMergeCommit commit.hash <&> \case - False -> [Revert commit.hash] - True -> [] - _ -> pure [] - _ -> pure [] - - let state = - MitState - { head = (), - merging = Nothing, - undos = - case (pushPushed push, committed) of - (False, False) -> context.state.undos - (False, True) -> - case context.snapshot of - Nothing -> [] - Just snapshot -> undoToSnapshot snapshot - (True, False) -> undoPush - (True, True) -> - if null undoPush - then [] - else case context.snapshot of - Nothing -> undoPush - Just snapshot -> undoPush ++ [Apply (fromJust snapshot.stash)] - } - - writeMitState context.branch state - - remoteCommits <- - case context.upstreamHead of - Nothing -> pure Seq.empty - Just upstreamHead -> gitCommitsBetween (Just "HEAD") upstreamHead - - conflictsOnSync <- - if Seq.null remoteCommits - then pure [] - else gitConflictsWith (fromJust context.upstreamHead) - - io do - putStanzas - [ isSynchronizedStanza context.branch push, - do - commits <- Seq1.fromSeq remoteCommits - syncStanza Sync {commits, success = False, source = upstream, target = context.branch}, - do - commits <- pushCommits push - syncStanza Sync {commits, success = pushPushed push, source = context.branch, target = upstream}, - case push of - DidntPush NothingToPush -> Nothing - DidntPush (PushWouldntReachRemote _) -> runSyncStanza "When you come online, run" context.branch upstream - DidntPush (PushWouldBeRejected _) -> - case List1.nonEmpty conflictsOnSync of - Nothing -> runSyncStanza "Run" context.branch upstream - Just conflictsOnSync1 -> - renderStanzas - [ conflictsStanza - ( "These files will be in conflict when you run " - <> Text.bold (Text.blue "mit sync") - <> ":" - ) - conflictsOnSync1, - Just $ - " Run " - <> Text.bold (Text.blue "mit sync") - <> ", resolve the conflicts, then run " - <> Text.bold (Text.blue "mit commit") - <> " to synchronize " - <> branchb context.branch - <> " with " - <> branchb upstream - <> "." - ] - DidntPush (TriedToPush _) -> runSyncStanza "Run" context.branch upstream - Pushed _ -> Nothing, - -- 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 not (null state.undos) && committed then canUndoStanza else Nothing - ] - -mitCommitMerge :: Mit Env () -mitCommitMerge = do - context <- getContext - let upstream = contextUpstream context - - -- Make the merge commit. Commonly we'll have gotten here by `mit merge `, so we'll have a `state0.merging` - -- that tells us we're merging in . But we also handle the case that we went `git merge` -> `mit commit`, - -- because why not. - case context.state.merging of - Nothing -> git_ ["commit", "--all", "--no-edit"] - Just merging -> - let message = fold ["⅄ ", if merging == context.branch then "" else merging <> " → ", context.branch] - in git_ ["commit", "--all", "--message", message] - - writeMitState context.branch context.state {merging = Nothing} - - let stanza0 = do - merging <- context.state.merging - guard (merging /= context.branch) - synchronizedStanza context.branch 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 undosStash context.state.undos of - Nothing -> mitSyncWith stanza0 (Just [Reset (fromJust context.snapshot).head]) - Just stash -> do - conflicts <- gitApplyStash stash - case List1.nonEmpty conflicts of - -- FIXME we just unstashed, now we're about to stash again :/ - Nothing -> mitSyncWith stanza0 (Just [Reset (fromJust context.snapshot).head, Apply stash]) - Just conflicts1 -> - io do - putStanzas - [ stanza0, - conflictsStanza "These files are in conflict:" conflicts1, - Just $ - " Resolve the conflicts, then run " - <> Text.bold (Text.blue "mit commit") - <> " to synchronize " - <> branchb context.branch - <> " with " - <> branchb upstream - <> ".", - if null context.state.undos then Nothing else canUndoStanza - ] - -mitMerge :: Goto Env [Stanza] -> Text -> Mit Env () -mitMerge return target = do - dieIfMergeInProgress return - whenM gitExistUntrackedFiles (dieIfBuggyGit return) - - context <- getContext - let upstream = contextUpstream context - - if target == context.branch || target == upstream - then -- If on branch `foo`, treat `mit merge foo` and `mit merge origin/foo` as `mit sync` - mitSyncWith Nothing Nothing - else mitMergeWith return context target - -mitMergeWith :: Goto Env [Stanza] -> Context -> Text -> Mit Env () -mitMergeWith return context target = do - -- When given 'mit merge foo', prefer running 'git merge origin/foo' over 'git merge foo' - targetCommit <- - gitRemoteBranchHead "origin" target - & onNothingM - ( gitBranchHead target - & onNothingM (return [Just (Text.red "No such branch.")]) - ) - - let upstream = contextUpstream context - - existRemoteCommits <- contextExistRemoteCommits context - existLocalCommits <- contextExistLocalCommits context - - when (existRemoteCommits && not existLocalCommits) do - return - [ notSynchronizedStanza context.branch upstream ".", - runSyncStanza "Run" context.branch upstream - ] - - whenJust (contextStash context) \_stash -> - gitDeleteChanges - - merge <- performMerge ("⅄ " <> target <> " → " <> context.branch) targetCommit - - stashConflicts <- - if null merge.conflicts - then case contextStash context of - Nothing -> pure [] - Just stash -> gitApplyStash stash - else pure [] - - push <- performPush context.branch - - let state = - MitState - { head = (), - merging = - if null merge.conflicts - then Nothing - else Just target, - undos = - if pushPushed push || Seq.null merge.commits - then [] - else case context.snapshot of - Nothing -> [] - Just snapshot -> undoToSnapshot snapshot - } - - writeMitState context.branch state - - remoteCommits <- - case context.upstreamHead of - Nothing -> pure Seq.empty - Just upstreamHead -> gitCommitsBetween (Just "HEAD") upstreamHead - - conflictsOnSync <- - if Seq.null remoteCommits - then pure [] - else gitConflictsWith (fromJust context.upstreamHead) - - io do - putStanzas - [ if null merge.conflicts - then synchronizedStanza context.branch target - else notSynchronizedStanza context.branch target ".", - do - commits1 <- Seq1.fromSeq merge.commits - syncStanza - Sync - { commits = commits1, - success = null merge.conflicts, - source = target, - target = context.branch - }, - isSynchronizedStanza context.branch push, - do - commits <- Seq1.fromSeq remoteCommits - syncStanza Sync {commits, success = False, source = upstream, target = context.branch}, - -- TODO show commits to remote - do - conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts - conflictsStanza "These files are in conflict:" conflicts1, - -- TODO audit this - case push of - DidntPush NothingToPush -> Nothing - DidntPush (PushWouldntReachRemote _) -> runSyncStanza "When you come online, run" context.branch upstream - -- FIXME hrm, but we might have merge conflicts and/or stash conflicts! - DidntPush (PushWouldBeRejected _) -> - case List1.nonEmpty conflictsOnSync of - Nothing -> runSyncStanza "Run" context.branch upstream - Just conflictsOnSync1 -> - renderStanzas - [ conflictsStanza - ( "These files will be in conflict when you run " - <> Text.bold (Text.blue "mit sync") - <> ":" - ) - conflictsOnSync1, - Just $ - " Run " - <> Text.bold (Text.blue "mit sync") - <> ", resolve the conflicts, then run " - <> Text.bold (Text.blue "mit commit") - <> " to synchronize " - <> branchb context.branch - <> " with " - <> branchb upstream - <> "." - ] - DidntPush (TriedToPush _) -> runSyncStanza "Run" context.branch upstream - Pushed _ -> Nothing, - if not (null state.undos) then canUndoStanza else Nothing - ] - --- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream -mitSync :: Goto Env [Stanza] -> Mit Env () -mitSync return = do - dieIfMergeInProgress return - whenM gitExistUntrackedFiles (dieIfBuggyGit return) - mitSyncWith Nothing 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 () -mitSyncWith stanza0 maybeUndos = do - context <- getContext - let upstream = contextUpstream context - - whenJust (contextStash context) \_stash -> - gitDeleteChanges - - merge <- - case context.upstreamHead of - -- Yay: no upstream branch is not different from an up-to-date local branch - Nothing -> pure GitMerge {commits = Seq.empty, conflicts = []} - Just upstreamHead -> performMerge ("⅄ " <> context.branch) upstreamHead - - stashConflicts <- - if null merge.conflicts - then case contextStash context of - Nothing -> pure [] - Just stash -> gitApplyStash stash - else pure [] - - push <- performPush context.branch - - let state = - MitState - { head = (), - merging = - if null merge.conflicts - then Nothing - else Just context.branch, - undos = - if pushPushed push - then [] - else case maybeUndos of - Nothing -> - if Seq.null merge.commits - then [] - else case context.snapshot of - Nothing -> [] - Just snapshot -> undoToSnapshot snapshot - -- FIXME hm, could consider appending those undos instead, even if they obviate the recent stash/merge - -- undos - Just undos' -> undos' - } - - writeMitState context.branch state - - io do - putStanzas - [ stanza0, - isSynchronizedStanza context.branch push, - do - commits1 <- Seq1.fromSeq merge.commits - syncStanza - Sync - { commits = commits1, - success = null merge.conflicts, - source = upstream, - target = context.branch - }, - do - commits <- pushCommits push - syncStanza - Sync - { commits, - success = pushPushed push, - source = context.branch, - target = upstream - }, - do - conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts - conflictsStanza "These files are in conflict:" conflicts1, - case push of - DidntPush NothingToPush -> Nothing - DidntPush (PushWouldntReachRemote _) -> runSyncStanza "When you come online, run" context.branch upstream - DidntPush (PushWouldBeRejected _) -> - Just $ - " Resolve the conflicts, then run " - <> Text.bold (Text.blue "mit commit") - <> " to synchronize " - <> branchb context.branch - <> " with " - <> branchb upstream - <> "." - DidntPush (TriedToPush _) -> runSyncStanza "Run" context.branch upstream - Pushed _ -> Nothing, - if not (null state.undos) then canUndoStanza else Nothing - ] - --- FIXME output what we just undid -mitUndo :: Goto Env [Stanza] -> Mit Env () -mitUndo return = do - context <- getContext - case List1.nonEmpty context.state.undos of - Nothing -> return [Just (Text.red "Nothing to undo.")] - Just undos1 -> for_ undos1 applyUndo - when (undosContainRevert context.state.undos) (mitSync return) - where - undosContainRevert :: [Undo] -> Bool - undosContainRevert = \case - [] -> False - Revert _ : _ -> True - _ : undos -> undosContainRevert undos - --- FIXME this type kinda sux now, replace with GitMerge probably? -data Sync = Sync - { commits :: Seq1 GitCommitInfo, - success :: Bool, - source :: Text, - target :: Text - } - -canUndoStanza :: Stanza -canUndoStanza = - Just (" Run " <> Text.bold (Text.blue "mit undo") <> " to undo this change.") - -conflictsStanza :: Text.Builder -> List1 GitConflict -> Stanza -conflictsStanza prefix conflicts = - Just $ - " " - <> prefix - <> Builder.newline - <> Builder.vcat ((\conflict -> " " <> Text.red (showGitConflict conflict)) <$> conflicts) - -isSynchronizedStanza :: Text -> GitPush -> Stanza -isSynchronizedStanza branch = \case - DidntPush NothingToPush -> synchronizedStanza branch upstream - DidntPush (PushWouldntReachRemote _) -> notSynchronizedStanza branch upstream " because you appear to be offline." - DidntPush (PushWouldBeRejected _) -> notSynchronizedStanza branch upstream "; their histories have diverged." - DidntPush (TriedToPush _) -> notSynchronizedStanza branch upstream (" because " <> Text.bold "git push" <> " failed.") - Pushed _ -> synchronizedStanza branch upstream - where - upstream = "origin/" <> branch - -notSynchronizedStanza :: Text -> Text -> Text.Builder -> Stanza -notSynchronizedStanza branch other suffix = - Just (" " <> Text.red (branchb branch <> " is not synchronized with " <> branchb other <> suffix)) - -runSyncStanza :: Text.Builder -> Text -> Text -> Stanza -runSyncStanza prefix branch upstream = - Just $ - " " - <> prefix - <> " " - <> Text.bold (Text.blue "mit sync") - <> " to synchronize " - <> branchb branch - <> " with " - <> branchb upstream - <> "." - -syncStanza :: Sync -> Stanza -syncStanza sync = - Just $ - Text.italic - (colorize (" " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)) - <> "\n" - <> (Builder.vcat ((\commit -> " " <> prettyGitCommitInfo commit) <$> commits')) - <> (if more then " ..." else Builder.empty) - where - colorize :: Text.Builder -> Text.Builder - colorize = - if sync.success then Text.green else Text.red - (commits', more) = - case Seq1.length sync.commits > 10 of - False -> (Seq1.toSeq sync.commits, False) - True -> (Seq1.dropEnd 1 sync.commits, True) - -synchronizedStanza :: Text -> Text -> Stanza -synchronizedStanza branch other = - Just (" " <> Text.green (branchb branch <> " is synchronized with " <> branchb other <> ".")) - -branchb :: Text -> Text.Builder -branchb = - Text.italic . Text.Builder.fromText - ------------------------------------------------------------------------------------------------------------------------- --- Context - -data Context = Context - { branch :: Text, - snapshot :: Maybe GitSnapshot, -- Nothing when no commits yet - state :: MitState (), - upstreamHead :: Maybe Text - } - -getContext :: Mit Env Context -getContext = do - gitFetch_ "origin" - branch <- git ["branch", "--show-current"] - upstreamHead <- gitRemoteBranchHead "origin" branch - state <- readMitState branch - snapshot <- performSnapshot - pure Context {branch, snapshot, state, upstreamHead} - -contextExistLocalCommits :: Context -> Mit Env Bool -contextExistLocalCommits context = - case context.upstreamHead of - Nothing -> pure True - Just upstreamHead -> - case context.snapshot of - Nothing -> pure False - Just snapshot -> gitExistCommitsBetween upstreamHead snapshot.head - -contextExistRemoteCommits :: Context -> Mit Env Bool -contextExistRemoteCommits context = - case context.upstreamHead of - Nothing -> pure False - Just upstreamHead -> - case context.snapshot of - Nothing -> pure True - Just snapshot -> gitExistCommitsBetween snapshot.head upstreamHead - -contextStash :: Context -> Maybe Text -contextStash context = do - snapshot <- context.snapshot - snapshot.stash - -contextUpstream :: Context -> Text -contextUpstream context = - "origin/" <> context.branch - ------------------------------------------------------------------------------------------------------------------------- --- 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. - commits :: Seq GitCommitInfo, - 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 GitMerge -performMerge message commitish = do - head <- gitHead - commits <- gitCommitsBetween (Just head) commitish - conflicts <- - if Seq.null commits - then pure [] - else - git ["merge", "--ff", "--no-commit", commitish] >>= \case - False -> gitConflicts - True -> do - -- If this was a fast-forward, a merge would not be in progress at this point. - whenM gitMergeInProgress (git_ ["commit", "--message", message]) - pure [] - pure GitMerge {commits, conflicts} - ------------------------------------------------------------------------------------------------------------------------- --- Git push - --- | The result of (considering a) git push. -data GitPush - = -- | We didn't push anthing. - DidntPush DidntPushReason - | -- | We successfully pushed commits. - Pushed (Seq1 GitCommitInfo) - -data DidntPushReason - = -- | There was nothing to push. - NothingToPush - | -- | We have commits to push, but we appear to be offline. - PushWouldntReachRemote (Seq1 GitCommitInfo) - | -- | We have commits to push, but there are also remote commits to merge. - PushWouldBeRejected (Seq1 GitCommitInfo) - | -- | We had commits to push, and tried to push, but it failed. - TriedToPush (Seq1 GitCommitInfo) - -pushCommits :: GitPush -> Maybe (Seq1 GitCommitInfo) -pushCommits = \case - DidntPush NothingToPush -> Nothing - DidntPush (PushWouldntReachRemote commits) -> Just commits - DidntPush (PushWouldBeRejected commits) -> Just commits - DidntPush (TriedToPush commits) -> Just commits - Pushed commits -> Just commits - -pushPushed :: GitPush -> Bool -pushPushed = \case - DidntPush _ -> False - Pushed _ -> True - --- TODO get context -performPush :: Text -> Mit Env GitPush -performPush branch = do - fetched <- gitFetch "origin" - head <- gitHead - upstreamHead <- gitRemoteBranchHead "origin" branch - commits <- gitCommitsBetween upstreamHead head - - case Seq1.fromSeq commits of - Nothing -> pure (DidntPush NothingToPush) - Just commits1 -> do - existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head) upstreamHead - if existRemoteCommits - then pure (DidntPush (PushWouldBeRejected commits1)) - else - if fetched - then do - gitPush branch <&> \case - False -> DidntPush (TriedToPush commits1) - True -> Pushed commits1 - else pure (DidntPush (PushWouldntReachRemote commits1)) - ------------------------------------------------------------------------------------------------------------------------- --- Git snapshot - -data GitSnapshot = GitSnapshot - { head :: Text, - stash :: Maybe Text - } - -performSnapshot :: Mit Env (Maybe GitSnapshot) -performSnapshot = do - gitMaybeHead >>= \case - Nothing -> pure Nothing - Just head -> do - stash <- - gitDiff >>= \case - Differences -> Just <$> gitCreateStash - NoDifferences -> pure Nothing - pure (Just GitSnapshot {head, stash}) - -undoToSnapshot :: GitSnapshot -> [Undo] -undoToSnapshot snapshot = - Reset snapshot.head : case snapshot.stash of - Nothing -> [] - Just stash -> [Apply stash] +import Data.Char qualified as Char +import Data.Foldable qualified as Foldable (toList) +import Data.Foldable1 (foldMap1') +import Data.List qualified as List +import Data.List.NonEmpty qualified as List1 +import Data.Semigroup qualified as Semigroup +import Data.Text qualified as Text +import Data.Text.Builder.Linear qualified as Text.Builder +import Mit.Command.Branch (mitBranch) +import Mit.Command.Commit (mitCommit) +import Mit.Command.Merge (mitMerge) +import Mit.Command.Status (mitStatus) +import Mit.Command.Undo (mitUndo) +import Mit.Git + ( GitCommitInfo (..), + GitConflict (..), + GitConflictXY (..), + GitVersion (GitVersion), + git, + gitApplyStash, + gitCurrentBranch, + gitFetch, + gitMaybeHead, + gitMergeInProgress, + gitRemoteBranchHead, + gitRevParseAbsoluteGitDir, + gitVersion, + ) +import Mit.Logger (Logger, log, makeLogger) +import Mit.Merge (MergeResult (..), mergeResultConflicts, performMerge) +import Mit.Output (Output) +import Mit.Output qualified as Output +import Mit.Prelude +import Mit.Pretty (Pretty) +import Mit.Pretty qualified as Pretty +import Mit.ProcessInfo (ProcessInfo (..)) +import Mit.Push + ( DidntPushReason (NothingToPush, PushWouldBeRejected, PushWouldntReachRemote, TriedToPush), + PushResult (DidntPush, Pushed), + performPush, + pushResultPushed, + ) +import Mit.Seq1 qualified as Seq1 +import Mit.Snapshot (performSnapshot, snapshotStash, undoToSnapshot) +import Mit.State (MitState (..), writeMitState) +import Mit.Undo (Undo (..)) +import Mit.Verbosity (Verbosity (..), intToVerbosity) +import Options.Applicative qualified as Opt +import Options.Applicative.Types qualified as Opt (Backtracking (Backtrack)) +import System.Exit (ExitCode (..), exitWith) +import Text.Builder.ANSI qualified as Text +import Text.Builder.ANSI qualified as Text.Builder +import Text.Printf (printf) +import UnconditionalJump (Label, goto, label) + +-- 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 +-- TODO `mit ignore ` stops tracking accidentally-added file and adds its name to .git/info/exclude + +-- TODO finish porting over to new "output as we go" style +-- TODO move commands into their own modules +-- TODO get rid of "snapshot" concept +-- TODO improve code paths with no remote configured (git remote show-url origin) + +main :: IO () +main = do + (verbosity, command) <- + Opt.customExecParser + Opt.ParserPrefs + { prefBacktrack = Opt.Backtrack, + prefColumns = 80, + prefDisambiguate = True, + prefHelpLongEquals = False, + prefHelpShowGlobal = True, + prefMultiSuffix = "+", + prefShowHelpOnEmpty = True, + prefShowHelpOnError = True, + prefTabulateFill = 24 -- grabbed this from optparse-applicative + } + ( Opt.info (Opt.helper <*> parser) $ + Opt.progDesc "mit: a git wrapper with a streamlined UX" + ) + + let output :: Logger Output + output = + makeLogger (putPretty . renderOutput) + + let pinfo :: Logger ProcessInfo + pinfo = + case verbosity of + V0 -> makeLogger \_ -> pure () + V1 -> makeLogger \info -> Pretty.put (v1 info) + V2 -> makeLogger \info -> Pretty.put (v1 info <> v2 info) + where + v1 :: ProcessInfo -> Pretty + v1 info = + Pretty.line $ + Pretty.style (Text.Builder.bold . Text.Builder.brightBlack) $ + let prefix = + marker info + <> " [" + <> Pretty.builder (foldMap Text.Builder.fromChar (printf "%.0f" (info.seconds * (1000 :: Double)) :: [Char])) + <> "ms] " + <> Pretty.text info.name + <> " " + in case List1.nonEmpty info.args of + Nothing -> prefix + Just args1 -> prefix <> sconcat (List1.intersperse (Pretty.char ' ') (quote <$> args1)) + v2 :: ProcessInfo -> Pretty + v2 info = + (info.output <> info.errput) + & Foldable.toList + & map (Pretty.style Text.Builder.brightBlack . Pretty.text) + & Pretty.lines + & Pretty.indent 4 + + quote :: Text -> Pretty.Line + quote s = + if Text.any Char.isSpace s + then Pretty.char '\'' <> Pretty.text (Text.replace "'" "\\'" s) <> Pretty.char '\'' + else Pretty.text s + + marker :: ProcessInfo -> Pretty.Line + marker info = + case info.exitCode of + ExitFailure _ -> Pretty.char '✗' + ExitSuccess -> Pretty.char '✓' + + exitCode <- main1 output pinfo command + exitWith exitCode + where + parser :: Opt.Parser (Verbosity, MitCommand) + parser = + (\verbosity command -> (verbosity, command)) + <$> (intToVerbosity . length <$> many (Opt.flag' () (Opt.help "Verbose (-v or -vv)" <> Opt.short 'v'))) + <*> (Opt.hsubparser . fold) + [ Opt.command "branch" $ + Opt.info + (MitCommand'Branch <$> Opt.strArgument (Opt.metavar "≪branch≫")) + (Opt.progDesc "Create a new branch in a new worktree."), + Opt.command "commit" $ + Opt.info + ( MitCommand'Commit + <$> Opt.switch (Opt.help "Include all changes" <> Opt.long "all") + <*> Opt.switch (Opt.help "Don't sync after committing" <> Opt.long "no-sync") + <*> Opt.optional + ( Opt.strOption $ + Opt.help "Commit message" + <> Opt.long "message" + <> Opt.metavar "≪message≫" + ) + ) + (Opt.progDesc "Create a commit."), + -- Opt.command "gc" $ + -- Opt.info + -- (pure MitCommand'Gc) + -- (Opt.progDesc "Delete stale, merged branches."), + Opt.command "merge" $ + Opt.info + (MitCommand'Merge <$> Opt.strArgument (Opt.metavar "≪branch≫")) + (Opt.progDesc "Merge the given branch into the current branch."), + Opt.command "status" $ + Opt.info + (pure MitCommand'Status) + (Opt.progDesc "Print file status."), + Opt.command "sync" $ + Opt.info + (pure MitCommand'Sync) + (Opt.progDesc "Sync with the remote named `origin`."), + Opt.command "undo" $ + Opt.info + (pure MitCommand'Undo) + (Opt.progDesc "Undo the last `mit` command (if possible).") + ] + +main1 :: Logger Output -> Logger ProcessInfo -> MitCommand -> IO ExitCode +main1 output pinfo command = + label \exit -> do + main2 exit output pinfo command + pure ExitSuccess + +main2 :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> MitCommand -> IO () +main2 exit output pinfo command = do + version <- gitVersion pinfo + -- 'git stash create' broken before 2.30.1 + when (version < GitVersion 2 30 1) do + log output Output.GitTooOld + goto exit (ExitFailure 1) + + gitdir <- + gitRevParseAbsoluteGitDir pinfo & onNothingM do + log output Output.NoGitDir + goto exit (ExitFailure 1) + + let sync = mitSync exit output pinfo gitdir + syncWith = mitSyncWith exit output pinfo gitdir + + case command of + MitCommand'Branch branch -> mitBranch exit output pinfo branch + MitCommand'Commit allFlag dontSyncFlag maybeMessage -> + mitCommit exit output pinfo syncWith gitdir allFlag dontSyncFlag maybeMessage + MitCommand'Gc -> mitGc + MitCommand'Merge branch -> mitMerge exit output pinfo (syncWith Nothing) gitdir branch + MitCommand'Status -> mitStatus pinfo + MitCommand'Sync -> sync + MitCommand'Undo -> mitUndo exit output pinfo sync gitdir + +data MitCommand + = MitCommand'Branch !Text + | MitCommand'Commit !Bool !Bool !(Maybe Text) + | MitCommand'Gc + | MitCommand'Merge !Text + | MitCommand'Status + | MitCommand'Sync + | MitCommand'Undo + +mitGc :: IO () +mitGc = + pure () + +-- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream +mitSync :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> Text -> IO () +mitSync exit output pinfo gitdir = do + whenM (gitMergeInProgress gitdir) do + log output Output.MergeInProgress + goto exit (ExitFailure 1) + mitSyncWith exit output pinfo gitdir 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 :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> Text -> Maybe Undo -> IO () +mitSyncWith exit output pinfo gitdir maybeUndo = do + fetched <- gitFetch pinfo "origin" + branch <- do + gitCurrentBranch pinfo & onNothingM do + log output Output.NotOnBranch + goto exit (ExitFailure 1) + maybeUpstreamHead <- gitRemoteBranchHead pinfo "origin" branch + snapshot <- performSnapshot pinfo + + whenJust (snapshotStash snapshot) \_stash -> + git @() pinfo ["reset", "--hard", "--quiet", "HEAD"] + + mergeResult <- + case maybeUpstreamHead of + -- Yay: no upstream branch is not different from an up-to-date local branch + Nothing -> pure NothingToMerge + Just upstreamHead -> performMerge pinfo gitdir upstreamHead ("⅄ " <> branch) + + case mergeResult of + NothingToMerge -> pure () + TriedToMerge commits conflicts -> log output (Output.PullFailed commits conflicts) + Merged commits -> log output (Output.PullSucceeded commits) + + maybeHead1 <- gitMaybeHead pinfo + + pushResult <- performPush pinfo branch maybeHead1 maybeUpstreamHead fetched + + case pushResult of + DidntPush NothingToPush -> pure () + DidntPush (PushWouldBeRejected localCommits numRemoteCommits) -> + log output (Output.PushWouldBeRejected localCommits numRemoteCommits) + DidntPush (PushWouldntReachRemote commits) -> log output (Output.PushWouldntReachRemote commits) + DidntPush (TriedToPush commits) -> log output (Output.PushFailed commits) + Pushed commits -> log output (Output.PushSucceeded commits) + + let undo1 = + case (pushResultPushed pushResult, maybeUndo, mergeResultConflicts mergeResult) of + (True, _, _) -> Nothing + -- FIXME hm, could consider appending those undos instead, even if they obviate the recent stash/merge + -- undos + (False, Just undo, _) -> Just undo + (False, Nothing, Nothing) -> Nothing + (False, Nothing, Just _conflicts) -> undoToSnapshot snapshot + + whenJust maybeHead1 \head1 -> + writeMitState + gitdir + branch + MitState + { head = head1, + merging = + case mergeResultConflicts mergeResult of + Nothing -> Nothing + Just _conflicts -> Just branch, + undo = undo1 + } + + when (isNothing (mergeResultConflicts mergeResult)) do + whenJust (snapshotStash snapshot) \stash -> do + conflicts0 <- gitApplyStash pinfo stash + whenJust (Seq1.fromList conflicts0) \conflicts1 -> log output (Output.UnstashFailed conflicts1) + + when (isJust undo1) (log output Output.CanUndo) + +putPretty :: Pretty -> IO () +putPretty p = + Pretty.put (emptyLine <> Pretty.indent 2 p <> emptyLine) + where + emptyLine = Pretty.line (Pretty.char ' ') + +------------------------------------------------------------------------------------------------------------------------ +-- Rendering output to the terminal + +renderOutput :: Output -> Pretty +renderOutput = \case + Output.BranchAlreadyCheckedOut branch dir1 dir2 -> + Pretty.line $ + Pretty.style Text.red $ + "✗ " + <> Pretty.branch branch + <> " is already checked out in " + <> Pretty.directory dir2 + <> ", so I can't check it out again in " + <> Pretty.directory dir1 + <> "." + Output.CanUndo -> Pretty.line ("Run " <> Pretty.command "mit undo" <> " to undo this change.") + Output.CheckedOutBranch branch directory -> + Pretty.line ("✓ I checked out " <> Pretty.branch branch <> " in " <> Pretty.directory directory) + Output.CreatedBranch branch directory -> + Pretty.line ("✓ I created " <> Pretty.branch branch <> " in " <> Pretty.directory directory <> ".") + Output.DirectoryAlreadyExists branch directory -> + Pretty.line $ + Pretty.style Text.red $ + "✗ I can't check out " + <> Pretty.branch branch + <> " in " + <> Pretty.directory directory + <> ", because the directory already exists." + Output.GitTooOld -> Pretty.line (Pretty.style Text.red "✗ I require git version 2.30.1 or later.") + Output.MergeFailed commits conflicts -> + Pretty.lines $ + Pretty.style + Text.red + ( "✗ I tried to merge " + <> commitsN (Seq1.length commits) + <> ", but there are conflicts." + ) + : map (\conflict -> " " <> Pretty.style Text.red (prettyGitConflict conflict)) (Seq1.toList conflicts) + Output.MergeSucceeded maybeCommits -> + case maybeCommits of + Nothing -> Pretty.line (Pretty.style Text.green "✓ I merged some commits.") + Just commits -> + Pretty.lines $ + Pretty.style Text.green ("✓ I merged " <> commitsN (Seq1.length commits) <> ".") + : Pretty.indent 2 (prettyCommits commits) + Output.MergeInProgress -> + Pretty.line $ + Pretty.style Text.red $ + "✗ There's currently a merge in progress that has to be resolved first." + Output.NoGitDir -> Pretty.line (Pretty.style Text.red "✗ The current directory doesn't contain a git repository.") + Output.NoSuchBranch -> Pretty.line (Pretty.style Text.red "✗ No such branch.") + Output.NotOnBranch -> Pretty.line (Pretty.style Text.red "✗ You are not on a branch.") + Output.NothingToCommit -> Pretty.line (Pretty.style Text.red "✗ There's nothing to commit.") + Output.NothingToMerge source target -> + Pretty.line $ + Pretty.style Text.green $ + "✓ " <> Pretty.branch target <> " is already up-to-date with " <> Pretty.branch source <> "." + Output.NothingToUndo -> Pretty.line (Pretty.style Text.red "✗ There's nothing to undo.") + Output.PullFailed commits conflicts -> + Pretty.lines $ + Pretty.style + Text.red + ( "✗ I tried to pull " + <> commitsN (Seq1.length commits) + <> ", but there are conflicts." + ) + : map (\conflict -> " " <> Pretty.style Text.red (prettyGitConflict conflict)) (Seq1.toList conflicts) + Output.PullSucceeded commits -> + Pretty.lines $ + Pretty.style Text.green ("✓ I pulled " <> commitsN (Seq1.length commits) <> ".") + : Pretty.indent 2 (prettyCommits commits) + Output.PushFailed commits -> + Pretty.line (Pretty.style Text.red ("✗ I tried to push " <> commitsN (Seq1.length commits) <> ", but failed.")) + Output.PushSucceeded commits -> + Pretty.lines $ + Pretty.style Text.green ("✓ I pushed " <> commitsN (Seq1.length commits) <> ".") + : Pretty.indent 2 (prettyCommits commits) + Output.PushWouldBeRejected localCommits numRemoteCommits -> + Pretty.line + ( Pretty.style + Text.red + ( "✗ I didn't try to push " + <> commitsN (Seq1.length localCommits) + <> ", because there " + <> commitsVN numRemoteCommits + <> " to pull first." + ) + ) + Output.PushWouldntReachRemote commits -> + Pretty.line + ( Pretty.style + Text.red + ("✗ I didn't try to push " <> commitsN (Seq1.length commits) <> ", because you appear to be offline.") + ) + Output.UnstashFailed conflicts -> + Pretty.lines $ + Pretty.style Text.red ("✗ I tried to restore your uncommitted changes, but there are conflicts.") + : map (\conflict -> " " <> Pretty.style Text.red (prettyGitConflict conflict)) (Seq1.toList conflicts) + Output.UpstreamIsAhead numRemoteCommits -> + Pretty.line (Pretty.style Text.red ("✗ There " <> commitsVN numRemoteCommits <> " to pull first.")) + where + commitsN :: Int -> Pretty.Line + commitsN = \case + 1 -> "1 commit" + n -> Pretty.int n <> " commits" + + commitsVN :: Int -> Pretty.Line + commitsVN = \case + 1 -> "is 1 commit" + n -> "are " <> Pretty.int n <> " commits" + +prettyCommits :: Seq1 GitCommitInfo -> Pretty +prettyCommits commits = + Pretty.lines $ + if Seq1.length commits <= 10 + then f (List.take 10 (Seq1.toList commits)) + else f (List.take 8 (Seq1.toList commits)) ++ ["│ ...", p (Seq1.last commits)] + where + f :: [GitCommitInfo] -> [Pretty.Line] + f = + snd . List.mapAccumL g "" + + g :: Text -> GitCommitInfo -> (Text, Pretty.Line) + g previousDate commit + | commit.date == previousDate = (previousDate, p commit {date = ""}) + | otherwise = (commit.date, p commit) + + p :: GitCommitInfo -> Pretty.Line + p commit = + "│ " <> prettyGitCommitInfo dateWidth commit + + dateWidth :: Int + dateWidth = + commits + & foldMap1' (\commit -> Semigroup.Max (Text.length commit.date)) + & Semigroup.getMax + +prettyGitCommitInfo :: Int -> GitCommitInfo -> Pretty.Line +prettyGitCommitInfo dateWidth info = + Pretty.style (Text.Builder.bold . Text.Builder.black) (Pretty.text info.shorthash) + <> Semigroup.stimes (dateWidth - thisDateWidth + 1) (Pretty.char ' ') + <> Pretty.style (Text.Builder.italic . Text.Builder.yellow) (Pretty.text info.date) + <> Pretty.char ' ' + <> Pretty.style (Text.Builder.bold . Text.Builder.white) (Pretty.text info.subject) + <> " - " + <> Pretty.style (Text.Builder.italic . Text.Builder.white) (Pretty.text info.author) + where + thisDateWidth = Text.length info.date + +prettyGitConflict :: GitConflict -> Pretty.Line +prettyGitConflict (GitConflict xy name) = + Pretty.text name <> " (" <> prettyGitConflictXY xy <> ")" + +prettyGitConflictXY :: GitConflictXY -> Pretty.Line +prettyGitConflictXY = \case + AA -> "both added" + AU -> "added by us" + DD -> "both deleted" + DU -> "deleted by us" + UA -> "added by them" + UD -> "deleted by them" + UU -> "both modified" diff --git a/src/Mit/Builder.hs b/src/Mit/Builder.hs deleted file mode 100644 --- a/src/Mit/Builder.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Mit.Builder - ( empty, - build, - hcat, - newline, - put, - putln, - space, - squoted, - vcat, - ) -where - -import Data.List qualified as List -import Data.Text.IO qualified as Text -import Data.Text.Lazy qualified as Text.Lazy -import Data.Text.Lazy.Builder -import Mit.Prelude - -empty :: Builder -empty = - mempty - -build :: Builder -> Text -build = - Text.Lazy.toStrict . toLazyText - -hcat :: Foldable f => f Builder -> Builder -hcat = - mconcat . List.intersperse space . toList - -newline :: Builder -newline = - singleton '\n' - -put :: Builder -> IO () -put = - Text.putStr . build - -putln :: Builder -> IO () -putln = - Text.putStrLn . build - -space :: Builder -space = - singleton ' ' - -squote :: Builder -squote = - singleton '\'' - -squoted :: Builder -> Builder -squoted s = - squote <> s <> squote - -vcat :: Foldable f => f Builder -> Builder -vcat = - mconcat . List.intersperse newline . toList diff --git a/src/Mit/Command/Branch.hs b/src/Mit/Command/Branch.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Command/Branch.hs @@ -0,0 +1,75 @@ +module Mit.Command.Branch + ( mitBranch, + ) +where + +import Data.Text qualified as Text +import Mit.Directory (cd, doesDirectoryExist) +import Mit.Git (git, gitBranchWorktreeDir, gitDefaultBranch, gitFetch, gitRemoteBranchExists) +import Mit.Logger (Logger, log) +import Mit.Output (Output) +import Mit.Output qualified as Output +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo) +import System.Exit (ExitCode (..)) +import UnconditionalJump (Label, goto, label) + +mitBranch :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> Text -> IO () +mitBranch exit output pinfo branch = do + -- Get the worktree directory that corresponds to the branch. + -- + -- For example, if the main branch (and git repo) is in /my/repo/main, and the branch is called "foo", then the + -- worktree directory is /my/repo/foo + worktreeDir <- do + rootdir <- git pinfo ["rev-parse", "--show-toplevel"] + pure (Text.dropWhileEnd (/= '/') rootdir <> branch) + + label \done -> do + -- It's possible that branch "foo" is already checked out in *some* worktree. If it is, we're done. + -- + -- If the branch's worktree is already where we were going to create it, this is just a do-nothing no-op. (Possible + -- improvement: output something here). + -- + -- If it isn't, that's an error; we'd like to check out "foo" in /my/repo/foo but it's already checked out in + -- /my/repo/bar?! Complain and quit. + gitBranchWorktreeDir pinfo branch & onJustM \directory -> + if directory == worktreeDir + then goto done () + else do + log output (Output.BranchAlreadyCheckedOut branch worktreeDir directory) + goto exit (ExitFailure 1) + + -- Maybe branch "foo" isn't checked out in any worktree, but there's already some directory at /my/repo/foo, which + -- is also a problem. + whenM (doesDirectoryExist worktreeDir) do + log output (Output.DirectoryAlreadyExists branch worktreeDir) + goto exit (ExitFailure 1) + + -- Create the new worktree with a detached HEAD. + git @() pinfo ["worktree", "add", "--detach", worktreeDir] + + -- Inside the new worktree directory... + cd worktreeDir do + -- Maybe branch "foo" already exists; try simply switching to it. If that works, we're done! + whenM (git pinfo ["switch", "--no-guess", "--quiet", branch]) do + log output (Output.CheckedOutBranch branch worktreeDir) + goto done () + + -- Ok, it doesn't exist; create it. + git @() pinfo ["branch", "--no-track", branch] + git @() pinfo ["switch", "--quiet", branch] + + _fetched <- gitFetch pinfo "origin" + gitRemoteBranchExists pinfo "origin" branch >>= \case + False -> do + -- Start the new branch at the latest origin/main, if there is an origin/main + -- This seems better than starting from whatever branch the user happened to fork from, which was + -- probably some slightly out-of-date main + whenJustM (gitDefaultBranch pinfo "origin") \defaultBranch -> + git @() pinfo ["reset", "--hard", "--quiet", "origin/" <> defaultBranch] + log output (Output.CreatedBranch branch worktreeDir) + True -> do + let upstream = "origin/" <> branch + git @() pinfo ["reset", "--hard", "--quiet", upstream] + git @() pinfo ["branch", "--quiet", "--set-upstream-to", upstream] + log output (Output.CreatedBranch branch worktreeDir) diff --git a/src/Mit/Command/Commit.hs b/src/Mit/Command/Commit.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Command/Commit.hs @@ -0,0 +1,253 @@ +module Mit.Command.Commit + ( mitCommit, + -- FIXME move this + abortIfCouldFastForwardToUpstream, + ) +where + +import Mit.Git + ( DiffResult (Differences, NoDifferences), + GitCommitInfo (..), + git, + git2, + gitApplyStash, + gitCreateStash, + gitCurrentBranch, + gitDiff, + gitExistCommitsBetween, + gitFetch, + gitIsMergeCommit, + gitMaybeHead, + gitMergeInProgress, + gitNumCommitsBetween, + gitNumCommitsOn, + gitRemoteBranchHead, + gitUnstageChanges, + ) +import Mit.Logger (Logger, log) +import Mit.Output (Output) +import Mit.Output qualified as Output +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo (..)) +import Mit.Push + ( DidntPushReason (NothingToPush, PushWouldBeRejected, PushWouldntReachRemote, TriedToPush), + PushResult (DidntPush, Pushed), + performPush, + pushResultPushed, + ) +import Mit.Seq1 qualified as Seq1 +import Mit.State (MitState (..), readMitState, writeMitState) +import Mit.Undo (Undo (..), undoStash) +import System.Exit (ExitCode (..)) +import System.Posix.Terminal (queryTerminal) +import UnconditionalJump (Label, goto) + +mitCommit :: + Label ExitCode -> + Logger Output -> + Logger ProcessInfo -> + (Maybe Undo -> IO ()) -> + Text -> + Bool -> + Bool -> + Maybe Text -> + IO () +mitCommit exit output pinfo sync gitdir allFlag dontSyncFlag maybeMessage = do + gitMergeInProgress gitdir >>= \case + False -> mitCommitNotMerge exit output pinfo gitdir allFlag dontSyncFlag maybeMessage + True -> mitCommitMerge exit output pinfo sync gitdir dontSyncFlag + +mitCommitMerge :: + Label ExitCode -> + Logger Output -> + Logger ProcessInfo -> + (Maybe Undo -> IO ()) -> + Text -> + Bool -> + IO () +mitCommitMerge exit output pinfo sync gitdir dontSyncFlag = do + branch <- + gitCurrentBranch pinfo & onNothingM do + log output Output.NotOnBranch + goto exit (ExitFailure 1) + head0 <- git pinfo ["rev-parse", "HEAD"] + maybeState0 <- readMitState gitdir branch head0 + let maybeMerging = maybeState0 >>= \state0 -> state0.merging + let maybeUndo = maybeState0 >>= \state0 -> state0.undo + + -- Make the merge commit. Commonly we'll have gotten here by `mit merge `, so we'll have a `state0.merging` + -- that tells us we're merging in . But we also handle the case that we went `git merge` -> `mit commit`, + -- because why not. + case maybeMerging of + Nothing -> git @() pinfo ["commit", "--all", "--no-edit"] + Just source -> + git @() + pinfo + [ "commit", + "--all", + "--message", + fold ["⅄ ", if source == branch then "" else source <> " → ", branch] + ] + + head1 <- git pinfo ["rev-parse", "HEAD"] + + -- Record that we are no longer merging. + writeMitState + gitdir + branch + MitState + { head = head1, + merging = Nothing, + undo = maybeUndo + } + + whenJust maybeMerging \source -> + when (source /= branch) (log output (Output.MergeSucceeded Nothing)) + + -- Three possible cases: + -- 1. We had a clean working directory before `mit merge`, so proceed to sync + -- 2. 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 + + case maybeUndo >>= undoStash of + Nothing -> when (not dontSyncFlag) (sync (Just (Reset head0))) + Just stash -> do + conflicts <- gitApplyStash pinfo stash + case Seq1.fromList conflicts of + -- FIXME we just unstashed, now we're about to stash again :/ + Nothing -> when (not dontSyncFlag) (sync (Just (ResetApply head0 stash))) + Just conflicts1 -> do + log output (Output.UnstashFailed conflicts1) + when (isJust maybeUndo) (log output Output.CanUndo) + +mitCommitNotMerge :: + Label ExitCode -> + Logger Output -> + Logger ProcessInfo -> + Text -> + Bool -> + Bool -> + Maybe Text -> + IO () +mitCommitNotMerge exit output pinfo gitdir allFlag dontSyncFlag maybeMessage = do + -- Check to see if there's even anything to commit, and bail if not. + gitUnstageChanges pinfo + gitDiff pinfo >>= \case + Differences -> pure () + NoDifferences -> do + log output Output.NothingToCommit + goto exit (ExitFailure 1) + + branch <- + gitCurrentBranch pinfo & onNothingM do + log output Output.NotOnBranch + goto exit (ExitFailure 1) + + fetched <- + if dontSyncFlag + then pure False + else gitFetch pinfo "origin" + maybeUpstreamHead <- gitRemoteBranchHead pinfo "origin" branch + maybeHead0 <- gitMaybeHead pinfo + abortIfCouldFastForwardToUpstream exit output pinfo maybeHead0 maybeUpstreamHead fetched + + maybeState0 <- + case maybeHead0 of + Nothing -> pure Nothing + Just head0 -> readMitState gitdir branch head0 + maybeStash <- if isJust maybeHead0 then gitCreateStash pinfo else pure Nothing + + -- Initiate a commit, which (if interactive) can be cancelled with Ctrl+C. + committed <- do + doCommitAll <- if allFlag then pure True else not <$> queryTerminal 0 + case (doCommitAll, maybeMessage) of + (True, Nothing) -> git2 pinfo ["commit", "--all", "--quiet"] + (True, Just message) -> git pinfo ["commit", "--all", "--message", message, "--quiet"] + (False, Nothing) -> git2 pinfo ["commit", "--patch", "--quiet"] + (False, Just message) -> git2 pinfo ["commit", "--patch", "--message", message, "--quiet"] + + -- Get the new head after the commit (if successful) + maybeHead1 <- if committed then Just <$> git pinfo ["rev-parse", "HEAD"] else pure maybeHead0 + + -- Attempt a push (even if the commit was cancelled, since we might have other unpublished commits). + pushResult <- + if dontSyncFlag + then pure (DidntPush NothingToPush) + else performPush pinfo branch maybeHead1 maybeUpstreamHead fetched + + case pushResult of + DidntPush NothingToPush -> pure () + DidntPush (PushWouldBeRejected localCommits numRemoteCommits) -> + log output (Output.PushWouldBeRejected localCommits numRemoteCommits) + DidntPush (PushWouldntReachRemote commits) -> log output (Output.PushWouldntReachRemote commits) + DidntPush (TriedToPush commits) -> log output (Output.PushFailed commits) + Pushed commits -> log output (Output.PushSucceeded commits) + + whenJust maybeHead1 \head1 -> do + maybeRevert <- + case pushResult of + Pushed commits -> + case Seq1.toList commits of + [commit] -> + gitIsMergeCommit pinfo commit.hash <&> \case + False -> Just commit.hash + True -> Nothing + _ -> pure Nothing + DidntPush _reason -> pure Nothing + + let maybeUndo1 = + case (pushResultPushed pushResult, committed) of + (False, False) -> maybeState0 >>= \state0 -> state0.undo + (False, True) -> + case maybeHead0 of + Nothing -> Nothing + Just head0 -> + Just case maybeStash of + Nothing -> Reset head0 + Just stash -> ResetApply head0 stash + (True, False) -> Revert <$> maybeRevert + (True, True) -> do + -- If we can revert the push *and* there is a stash in the snapshot (i.e. this *isnt* the very first + -- commit), then we can undo (by reverting then applying the stash). + -- + -- But if (for example) we can revert the push but there is *not* a stash in the snapshot, that means + -- there were no commits before this one (`git stash create` is illegal there), so we don't want to + -- offer to undo, because although we can revert the commit, we have no way of getting from there to + -- back to having some dirty stuff to commit. + RevertApply <$> maybeRevert <*> maybeStash + + writeMitState gitdir branch MitState {head = head1, merging = Nothing, undo = maybeUndo1} + + -- 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. + when (isJust maybeUndo1 && committed) (log output Output.CanUndo) + +-- If origin/branch is strictly ahead of branch (so we could fast-forward), abort, but if we successfully fetched, +-- because we do want to allow offline activity regardless. +abortIfCouldFastForwardToUpstream :: + Label ExitCode -> + Logger Output -> + Logger ProcessInfo -> + Maybe Text -> + Maybe Text -> + Bool -> + IO () +abortIfCouldFastForwardToUpstream exit output pinfo maybeHead maybeUpstreamHead fetched = do + when fetched do + whenJust maybeUpstreamHead \upstreamHead -> do + head <- + maybeHead & onNothing do + numRemoteCommits <- gitNumCommitsOn pinfo upstreamHead + log output (Output.UpstreamIsAhead numRemoteCommits) + goto exit (ExitFailure 1) + numRemoteCommits <- gitNumCommitsBetween pinfo head upstreamHead + when (numRemoteCommits > 0) do + whenNotM (gitExistCommitsBetween pinfo upstreamHead head) do + log output (Output.UpstreamIsAhead numRemoteCommits) + goto exit (ExitFailure 1) diff --git a/src/Mit/Command/Merge.hs b/src/Mit/Command/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Command/Merge.hs @@ -0,0 +1,111 @@ +module Mit.Command.Merge + ( mitMerge, + ) +where + +import Mit.Command.Commit (abortIfCouldFastForwardToUpstream) +import Mit.Git + ( git, + gitApplyStash, + gitCurrentBranch, + gitFetch, + gitMaybeHead, + gitMergeInProgress, + gitRemoteBranchHead, + ) +import Mit.Logger (Logger, log) +import Mit.Merge (MergeResult (..), mergeResultConflicts, performMerge) +import Mit.Output (Output) +import Mit.Output qualified as Output +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo (..)) +import Mit.Push + ( DidntPushReason (NothingToPush, PushWouldBeRejected, PushWouldntReachRemote, TriedToPush), + PushResult (DidntPush, Pushed), + performPush, + pushResultPushed, + ) +import Mit.Seq1 qualified as Seq1 +import Mit.Snapshot (performSnapshot, snapshotStash, undoToSnapshot) +import Mit.State (MitState (..), writeMitState) +import System.Exit (ExitCode (..)) +import UnconditionalJump (Label, goto) + +mitMerge :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> IO () -> Text -> Text -> IO () +mitMerge exit output pinfo sync gitdir source = do + whenM (gitMergeInProgress gitdir) do + log output Output.MergeInProgress + goto exit (ExitFailure 1) + + branch <- + gitCurrentBranch pinfo & onNothingM do + log output Output.NotOnBranch + goto exit (ExitFailure 1) + + let upstream = "origin/" <> branch + + -- Special case: if on branch "foo", treat `mit merge foo` and `mit merge origin/foo` as `mit sync` + case source == branch || source == upstream of + True -> sync + False -> mitMerge_ exit output pinfo gitdir source branch + +mitMerge_ :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> Text -> Text -> Text -> IO () +mitMerge_ exit output pinfo gitdir source branch = do + fetched <- gitFetch pinfo "origin" + maybeHead0 <- gitMaybeHead pinfo + maybeUpstreamHead <- gitRemoteBranchHead pinfo "origin" branch + snapshot <- performSnapshot pinfo + + -- When given 'mit merge foo', prefer running 'git merge origin/foo' over 'git merge foo' + sourceCommit <- + gitRemoteBranchHead pinfo "origin" source & onNothingM do + git pinfo ["rev-parse", "refs/heads/" <> source] & onLeftM \_ -> do + log output Output.NoSuchBranch + goto exit (ExitFailure 1) + + abortIfCouldFastForwardToUpstream exit output pinfo maybeHead0 maybeUpstreamHead fetched + + whenJust (snapshotStash snapshot) \_stash -> + git @() pinfo ["reset", "--hard", "--quiet", "HEAD"] + + mergeResult <- performMerge pinfo gitdir sourceCommit ("⅄ " <> source <> " → " <> branch) + + log output case mergeResult of + NothingToMerge -> Output.NothingToMerge source branch + TriedToMerge commits conflicts -> Output.MergeFailed commits conflicts + Merged commits -> Output.MergeSucceeded (Just commits) + + head1 <- git pinfo ["rev-parse", "HEAD"] -- FIXME oops this can be Nothing + pushResult <- performPush pinfo branch (Just head1) maybeUpstreamHead fetched + + case pushResult of + DidntPush NothingToPush -> pure () + DidntPush (PushWouldBeRejected localCommits numRemoteCommits) -> + log output (Output.PushWouldBeRejected localCommits numRemoteCommits) + DidntPush (PushWouldntReachRemote commits) -> log output (Output.PushWouldntReachRemote commits) + DidntPush (TriedToPush commits) -> log output (Output.PushFailed commits) + Pushed commits -> log output (Output.PushSucceeded commits) + + let undo1 = + if pushResultPushed pushResult || isNothing (mergeResultConflicts mergeResult) + then Nothing + else undoToSnapshot snapshot + + writeMitState + gitdir + branch + MitState + { head = head1, + merging = + case mergeResultConflicts mergeResult of + Nothing -> Nothing + Just _conflicts -> Just source, + undo = undo1 + } + + when (isNothing (mergeResultConflicts mergeResult)) do + whenJust (snapshotStash snapshot) \stash -> do + conflicts0 <- gitApplyStash pinfo stash + whenJust (Seq1.fromList conflicts0) \conflicts1 -> log output (Output.UnstashFailed conflicts1) + + when (isJust undo1) (log output Output.CanUndo) diff --git a/src/Mit/Command/Status.hs b/src/Mit/Command/Status.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Command/Status.hs @@ -0,0 +1,16 @@ +module Mit.Command.Status + ( mitStatus, + ) +where + +import Mit.Git (git, gitUnstageChanges) +import Mit.Logger (Logger) +import Mit.Prelude +import Mit.Pretty qualified as Pretty +import Mit.ProcessInfo (ProcessInfo) + +mitStatus :: Logger ProcessInfo -> IO () +mitStatus pinfo = do + gitUnstageChanges pinfo + lines <- git pinfo ["status", "--porcelain=v1"] + Pretty.put (Pretty.lines (map Pretty.text lines)) diff --git a/src/Mit/Command/Sync.hs b/src/Mit/Command/Sync.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Command/Sync.hs @@ -0,0 +1,126 @@ +module Mit.Command.Sync + ( mitSync, + mitSyncWith, + ) +where + +import Mit.Git + ( git, + gitApplyStash, + gitCurrentBranch, + gitFetch, + gitMaybeHead, + gitMergeInProgress, + gitRemoteBranchHead, + ) +import Mit.Logger (Logger, log) +import Mit.Merge (MergeResult (..), mergeResultConflicts, performMerge) +import Mit.Output (Output) +import Mit.Output qualified as Output +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo (..)) +import Mit.Push + ( DidntPushReason (NothingToPush, PushWouldBeRejected, PushWouldntReachRemote, TriedToPush), + PushResult (DidntPush, Pushed), + performPush, + pushResultPushed, + ) +import Mit.Seq1 qualified as Seq1 +import Mit.Snapshot (performSnapshot, snapshotStash, undoToSnapshot) +import Mit.State (MitState (..), writeMitState) +import Mit.Undo (Undo (..)) +import System.Exit (ExitCode (..)) +import UnconditionalJump (Label, goto) + +-- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream +mitSync :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> Text -> IO () +mitSync exit output pinfo gitdir = do + whenM (gitMergeInProgress gitdir) do + log output Output.MergeInProgress + goto exit (ExitFailure 1) + mitSyncWith exit output pinfo gitdir 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 :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> Text -> Maybe Undo -> IO () +mitSyncWith exit output pinfo gitdir maybeUndo = do + fetched <- gitFetch pinfo "origin" + branch <- do + gitCurrentBranch pinfo & onNothingM do + log output Output.NotOnBranch + goto exit (ExitFailure 1) + maybeUpstreamHead <- gitRemoteBranchHead pinfo "origin" branch + snapshot <- performSnapshot pinfo + + whenJust (snapshotStash snapshot) \_stash -> + git @() pinfo ["reset", "--hard", "--quiet", "HEAD"] + + mergeResult <- + case maybeUpstreamHead of + -- Yay: no upstream branch is not different from an up-to-date local branch + Nothing -> pure NothingToMerge + Just upstreamHead -> performMerge pinfo gitdir upstreamHead ("⅄ " <> branch) + + case mergeResult of + NothingToMerge -> pure () + TriedToMerge commits conflicts -> log output (Output.PullFailed commits conflicts) + Merged commits -> log output (Output.PullSucceeded commits) + + maybeHead1 <- gitMaybeHead pinfo + + pushResult <- performPush pinfo branch maybeHead1 maybeUpstreamHead fetched + + case pushResult of + DidntPush NothingToPush -> pure () + DidntPush (PushWouldBeRejected localCommits numRemoteCommits) -> + log output (Output.PushWouldBeRejected localCommits numRemoteCommits) + DidntPush (PushWouldntReachRemote commits) -> log output (Output.PushWouldntReachRemote commits) + DidntPush (TriedToPush commits) -> log output (Output.PushFailed commits) + Pushed commits -> log output (Output.PushSucceeded commits) + + let undo1 = + case (pushResultPushed pushResult, maybeUndo, mergeResultConflicts mergeResult) of + (True, _, _) -> Nothing + -- FIXME hm, could consider appending those undos instead, even if they obviate the recent stash/merge + -- undos + (False, Just undo, _) -> Just undo + (False, Nothing, Nothing) -> Nothing + (False, Nothing, Just _conflicts) -> undoToSnapshot snapshot + + whenJust maybeHead1 \head1 -> + writeMitState + gitdir + branch + MitState + { head = head1, + merging = + case mergeResultConflicts mergeResult of + Nothing -> Nothing + Just _conflicts -> Just branch, + undo = undo1 + } + + when (isNothing (mergeResultConflicts mergeResult)) do + whenJust (snapshotStash snapshot) \stash -> do + conflicts0 <- gitApplyStash pinfo stash + whenJust (Seq1.fromList conflicts0) \conflicts1 -> log output (Output.UnstashFailed conflicts1) + + when (isJust undo1) (log output Output.CanUndo) diff --git a/src/Mit/Command/Undo.hs b/src/Mit/Command/Undo.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Command/Undo.hs @@ -0,0 +1,38 @@ +module Mit.Command.Undo + ( mitUndo, + ) +where + +import Mit.Git (git, gitCurrentBranch, gitMaybeHead) +import Mit.Logger (Logger, log) +import Mit.Output (Output) +import Mit.Output qualified as Output +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo) +import Mit.State (MitState (..), readMitState) +import Mit.Undo (applyUndo) +import System.Exit (ExitCode (..)) +import UnconditionalJump (Label, goto) + +-- FIXME output what we just undid +mitUndo :: Label ExitCode -> Logger Output -> Logger ProcessInfo -> IO () -> Text -> IO () +mitUndo exit output pinfo sync gitdir = do + branch <- + gitCurrentBranch pinfo & onNothingM do + log output Output.NotOnBranch + goto exit (ExitFailure 1) + headBefore <- + gitMaybeHead pinfo & onNothingM do + log output Output.NothingToUndo + goto exit (ExitFailure 1) + state <- + readMitState gitdir branch headBefore & onNothingM do + log output Output.NothingToUndo + goto exit (ExitFailure 1) + undo <- + state.undo & onNothing do + log output Output.NothingToUndo + goto exit (ExitFailure 1) + applyUndo pinfo undo + headAfter <- git pinfo ["rev-parse", "HEAD"] + when (headBefore /= headAfter) sync diff --git a/src/Mit/Directory.hs b/src/Mit/Directory.hs --- a/src/Mit/Directory.hs +++ b/src/Mit/Directory.hs @@ -5,15 +5,14 @@ where import Data.Text qualified as Text -import Mit.Monad import Mit.Prelude import System.Directory qualified as Directory -cd :: Text -> Mit r a -> Mit r a +-- | Change the working directory. +cd :: Text -> IO a -> IO a cd dir = - with_ (Directory.withCurrentDirectory (Text.unpack dir)) + Directory.withCurrentDirectory (Text.unpack dir) --- | Change directories (delimited by 'block'). -doesDirectoryExist :: MonadIO m => Text -> m Bool +doesDirectoryExist :: Text -> IO Bool doesDirectoryExist = - liftIO . Directory.doesDirectoryExist . Text.unpack + Directory.doesDirectoryExist . Text.unpack diff --git a/src/Mit/Env.hs b/src/Mit/Env.hs deleted file mode 100644 --- a/src/Mit/Env.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Mit.Env - ( Env (..), - ) -where - -import Mit.Prelude - -data Env = Env - { verbosity :: Int - } diff --git a/src/Mit/Git.hs b/src/Mit/Git.hs --- a/src/Mit/Git.hs +++ b/src/Mit/Git.hs @@ -2,71 +2,68 @@ module Mit.Git ( DiffResult (..), GitCommitInfo (..), - prettyGitCommitInfo, - GitConflict, - showGitConflict, + GitConflict (..), + GitConflictXY (..), GitVersion (..), showGitVersion, git, - git_, + git2, gitApplyStash, - gitBranchHead, gitBranchWorktreeDir, - gitCommit, gitCommitsBetween, gitConflicts, - gitConflictsWith, gitCreateStash, - gitDeleteChanges, + gitCurrentBranch, gitDiff, gitExistCommitsBetween, gitExistUntrackedFiles, gitFetch, - gitFetch_, - gitHead, gitIsMergeCommit, gitMaybeHead, gitMergeInProgress, - gitPush, + gitNumCommitsBetween, + gitNumCommitsOn, gitRemoteBranchExists, gitRemoteBranchHead, gitRevParseAbsoluteGitDir, gitUnstageChanges, gitVersion, -- unused, but useful? not sure + gitConflictsWith, gitDefaultBranch, gitShow, parseGitRepo, ) where +import Data.Char qualified as Char import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Sequence qualified as Seq import Data.Text qualified as Text -import Data.Text.Builder.ANSI qualified as Text.Builder import Data.Text.IO qualified as Text -import Data.Text.Lazy.Builder qualified as Text (Builder) -import Data.Text.Lazy.Builder qualified as Text.Builder -import Data.Text.Lazy.Builder.RealFloat qualified as Text.Builder +import Data.Text.Read qualified as Text.Read import GHC.Clock (getMonotonicTime) import Ki qualified -import Mit.Builder qualified as Builder -import Mit.Env (Env (..)) -import Mit.Monad +import Mit.Logger (Logger, log) import Mit.Prelude -import Mit.Process -import Mit.Stanza +import Mit.Process (ProcessOutput (..)) +import Mit.ProcessInfo (ProcessInfo (..)) import System.Directory (doesFileExist) -import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) import System.IO (Handle, hClose, hIsEOF) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Process (getProcessGroupIDOf) -import System.Posix.Signals -import System.Posix.Terminal (queryTerminal) +import System.Posix.Signals (sigTERM, signalProcessGroup) import System.Process -import System.Process.Internals + ( CmdSpec (RawCommand), + CreateProcess (..), + ProcessHandle, + StdStream (CreatePipe, Inherit, NoStream), + createProcess, + waitForProcess, + ) +import System.Process.Internals (ProcessHandle__ (ClosedHandle, OpenExtHandle, OpenHandle), withProcessHandle) import Text.Parsec qualified as Parsec data DiffResult @@ -88,18 +85,6 @@ [author, date, hash, shorthash, subject] -> GitCommitInfo {author, date, hash, shorthash, subject} _ -> error (Text.unpack line) -prettyGitCommitInfo :: GitCommitInfo -> Text.Builder -prettyGitCommitInfo info = - fold - [ Text.Builder.bold (Text.Builder.black (Text.Builder.fromText info.shorthash)), - Builder.space, - Text.Builder.bold (Text.Builder.white (Text.Builder.fromText info.subject)), - " - ", - Text.Builder.italic (Text.Builder.white (Text.Builder.fromText info.author)), - Builder.space, - Text.Builder.italic (Text.Builder.yellow (Text.Builder.fromText info.date)) - ] - -- FIXME some other color, magenta? data GitConflict @@ -132,10 +117,6 @@ [xy, name] <- Just (Text.words line) GitConflict <$> parseGitConflictXY xy <*> Just name -showGitConflict :: GitConflict -> Text.Builder -showGitConflict (GitConflict xy name) = - Text.Builder.fromText name <> " (" <> showGitConflictXY xy <> ")" - data GitConflictXY = AA -- both added | AU -- added by us @@ -157,16 +138,6 @@ "UU" -> Just UU _ -> Nothing -showGitConflictXY :: GitConflictXY -> Text.Builder -showGitConflictXY = \case - AA -> "both added" - AU -> "added by us" - DD -> "both deleted" - DU -> "deleted by us" - UA -> "added by them" - UD -> "deleted by them" - UU -> "both modified" - data GitVersion = GitVersion Int Int Int deriving stock (Eq, Ord) @@ -176,53 +147,34 @@ Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z) -- | Apply stash, return conflicts. -gitApplyStash :: Text -> Mit Env [GitConflict] -gitApplyStash stash = do +gitApplyStash :: Logger ProcessInfo -> Text -> IO [GitConflict] +gitApplyStash logger stash = do conflicts <- - git ["stash", "apply", "--quiet", stash] >>= \case - False -> gitConflicts + git logger ["stash", "apply", "--quiet", stash] >>= \case + False -> gitConflicts logger True -> pure [] - gitUnstageChanges + gitUnstageChanges logger pure conflicts --- | Get the head of a local branch (refs/heads/...). -gitBranchHead :: Text -> Mit Env (Maybe Text) -gitBranchHead branch = - git ["rev-parse", "refs/heads/" <> branch] <&> \case - Left _ -> Nothing - Right head -> Just head - -- | Get the directory a branch's worktree is checked out in, if it exists. -gitBranchWorktreeDir :: Text -> Mit Env (Maybe Text) -gitBranchWorktreeDir branch = do - worktrees <- gitWorktreeList +gitBranchWorktreeDir :: Logger ProcessInfo -> Text -> IO (Maybe Text) +gitBranchWorktreeDir logger branch = do + worktrees <- gitListWorktrees logger pure case List.find (\worktree -> worktree.branch == Just branch) worktrees of Nothing -> Nothing Just worktree -> Just worktree.directory -gitCommit :: Mit Env Bool -gitCommit = - io (queryTerminal 0) >>= \case - False -> do - message <- io (lookupEnv "MIT_COMMIT_MESSAGE") - git ["commit", "--all", "--message", maybe "" Text.pack message] - True -> - git2 ["commit", "--patch", "--quiet"] <&> \case - ExitFailure _ -> False - ExitSuccess -> True - -gitCommitsBetween :: Maybe Text -> Text -> Mit Env (Seq GitCommitInfo) -gitCommitsBetween commit1 commit2 = +gitCommitsBetween :: Logger ProcessInfo -> Maybe Text -> Text -> IO (Seq GitCommitInfo) +gitCommitsBetween logger commit1 commit2 = if commit1 == Just commit2 then pure Seq.empty else do commits <- -- --first-parent seems desirable for topic branches git + logger [ "rev-list", - "--color=always", - "--date=human", - "--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s", + "--format=format:%an\xFEFF%ah\xFEFF%H\xFEFF%h\xFEFF%s", "--max-count=11", maybe id (\c1 c2 -> c1 <> ".." <> c2) commit1 commit2 ] @@ -234,68 +186,77 @@ _ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs xs -> xs -gitConflicts :: Mit Env [GitConflict] -gitConflicts = - mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"] +gitConflicts :: Logger ProcessInfo -> IO [GitConflict] +gitConflicts logger = + mapMaybe parseGitConflict <$> git logger ["status", "--no-renames", "--porcelain=v1"] -- | Get the conflicts with the given commitish. -- -- Precondition: there is no merge in progress. -gitConflictsWith :: Text -> Mit Env [GitConflict] -gitConflictsWith commit = do - maybeStash <- gitStash +gitConflictsWith :: Logger ProcessInfo -> Text -> Text -> IO [GitConflict] +gitConflictsWith logger gitdir commit = do + maybeStash <- gitStash logger conflicts <- do - git ["merge", "--no-commit", "--no-ff", commit] >>= \case - False -> gitConflicts + git logger ["merge", "--no-commit", "--no-ff", commit] >>= \case + False -> gitConflicts logger True -> pure [] - whenM gitMergeInProgress (git_ ["merge", "--abort"]) - whenJust maybeStash \stash -> git ["stash", "apply", "--quiet", stash] + whenM (gitMergeInProgress gitdir) (git @() logger ["merge", "--abort"]) + whenJust maybeStash \stash -> git logger ["stash", "apply", "--quiet", stash] pure conflicts --- | Precondition: there are changes to stash -gitCreateStash :: Mit Env Text -gitCreateStash = do - git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed - stash <- git ["stash", "create"] - gitUnstageChanges +gitCreateStash :: Logger ProcessInfo -> IO (Maybe Text) +gitCreateStash logger = do + git @() logger ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed + stash <- + git logger ["stash", "create"] <&> \case + Seq.Empty -> Nothing + stash Seq.:<| _ -> Just stash + -- Even if the stash is Nothing, this still might be relevant/necessary. + -- In particular, if there are only changes to submodule commits, we'll have staged them with 'git add' --all, then + -- we'll have gotten no stash back from 'git stash create'. + gitUnstageChanges logger pure stash -gitDefaultBranch :: Text -> Mit Env Text -gitDefaultBranch remote = do - ref <- git ["symbolic-ref", "refs/remotes/" <> remote <> "/HEAD"] - pure (Text.drop (14 + Text.length remote) ref) +-- | Get the name of the current branch. +gitCurrentBranch :: Logger ProcessInfo -> IO (Maybe Text) +gitCurrentBranch logger = + git logger ["branch", "--show-current"] <&> \case + Seq.Empty -> Nothing + branch Seq.:<| _ -> Just branch --- | Delete all changes in the index and working tree. -gitDeleteChanges :: Mit Env () -gitDeleteChanges = - git_ ["reset", "--hard", "--quiet", "HEAD"] +gitDefaultBranch :: Logger ProcessInfo -> Text -> IO (Maybe Text) +gitDefaultBranch logger remote = + git logger ["symbolic-ref", "refs/remotes/" <> remote <> "/HEAD"] <&> \case + Left _code -> Nothing + Right branch -> Just (Text.drop (14 + Text.length remote) branch) --- FIXME document this -gitDiff :: Mit Env DiffResult -gitDiff = do - gitUnstageChanges - git ["diff", "--quiet"] <&> \case +-- | Report whether there are any tracked, unstaged changes. +gitDiff :: Logger ProcessInfo -> IO DiffResult +gitDiff logger = do + git logger ["diff", "--quiet"] <&> \case False -> Differences True -> NoDifferences -gitExistCommitsBetween :: Text -> Text -> Mit Env Bool -gitExistCommitsBetween commit1 commit2 = +gitExistCommitsBetween :: Logger ProcessInfo -> Text -> Text -> IO Bool +gitExistCommitsBetween logger commit1 commit2 = if commit1 == commit2 then pure False - else isJust <$> git ["rev-list", "--max-count=1", commit1 <> ".." <> commit2] + else do + commits <- git logger ["rev-list", "--max-count=1", commit1 <> ".." <> commit2] + pure (not (Seq.null commits)) -- | Do any untracked files exist? -gitExistUntrackedFiles :: Mit Env Bool -gitExistUntrackedFiles = - not . null <$> gitListUntrackedFiles +gitExistUntrackedFiles :: Logger ProcessInfo -> IO Bool +gitExistUntrackedFiles logger = + not . null <$> gitListUntrackedFiles logger -gitFetch :: Text -> Mit Env Bool -gitFetch remote = do - fetched <- io (readIORef fetchedRef) +gitFetch :: Logger ProcessInfo -> Text -> IO Bool +gitFetch logger remote = do + fetched <- readIORef fetchedRef case Map.lookup remote fetched of Nothing -> do - success <- git ["fetch", remote] - io (writeIORef fetchedRef (Map.insert remote success fetched)) + success <- git logger ["fetch", "--atomic", remote] + writeIORef fetchedRef (Map.insert remote success fetched) pure success Just success -> pure success @@ -305,62 +266,68 @@ unsafePerformIO (newIORef mempty) {-# NOINLINE fetchedRef #-} -gitFetch_ :: Text -> Mit Env () -gitFetch_ = - void . gitFetch - --- | Get the head commit. -gitHead :: Mit Env Text -gitHead = - git ["rev-parse", "HEAD"] - -- | Get whether a commit is a merge commit. -gitIsMergeCommit :: Text -> Mit Env Bool -gitIsMergeCommit commit = - git ["rev-parse", "--quiet", "--verify", commit <> "^2"] +gitIsMergeCommit :: Logger ProcessInfo -> Text -> IO Bool +gitIsMergeCommit logger commit = + git logger ["rev-parse", "--quiet", "--verify", commit <> "^2"] -- | List all untracked files. -gitListUntrackedFiles :: Mit Env [Text] -gitListUntrackedFiles = - git ["ls-files", "--exclude-standard", "--other"] +gitListUntrackedFiles :: Logger ProcessInfo -> IO [Text] +gitListUntrackedFiles logger = + git logger ["ls-files", "--exclude-standard", "--other"] -- | Get the head commit, if it exists. -gitMaybeHead :: Mit Env (Maybe Text) -gitMaybeHead = - git ["rev-parse", "HEAD"] <&> \case +gitMaybeHead :: Logger ProcessInfo -> IO (Maybe Text) +gitMaybeHead logger = + git logger ["rev-parse", "HEAD"] <&> \case Left _ -> Nothing Right commit -> Just commit -- | Get whether a merge is in progress. -gitMergeInProgress :: Mit Env Bool -gitMergeInProgress = do - gitdir <- gitRevParseAbsoluteGitDir - io (doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD"))) +gitMergeInProgress :: Text -> IO Bool +gitMergeInProgress gitdir = + doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD")) -gitPush :: Text -> Mit Env Bool -gitPush branch = - git ["push", "--set-upstream", "origin", "--quiet", branch <> ":" <> branch] +gitNumCommitsBetween :: Logger ProcessInfo -> Text -> Text -> IO Int +gitNumCommitsBetween logger commit1 commit2 = + if commit1 == commit2 + then pure 0 + else do + commitsString <- git logger ["rev-list", "--count", commit1 <> ".." <> commit2] + pure case Text.Read.decimal commitsString of + Right (commits, "") -> commits + _ -> 0 +gitNumCommitsOn :: Logger ProcessInfo -> Text -> IO Int +gitNumCommitsOn logger commit = do + commitsString <- git logger ["rev-list", "--count", commit] + pure case Text.Read.decimal commitsString of + Right (commits, "") -> commits + _ -> 0 + -- | Does the given remote branch (refs/remotes/...) exist? -gitRemoteBranchExists :: Text -> Text -> Mit Env Bool -gitRemoteBranchExists remote branch = - git ["rev-parse", "--quiet", "--verify", "refs/remotes/" <> remote <> "/" <> branch] +gitRemoteBranchExists :: Logger ProcessInfo -> Text -> Text -> IO Bool +gitRemoteBranchExists logger remote branch = + git logger ["rev-parse", "--quiet", "--verify", "refs/remotes/" <> remote <> "/" <> branch] -- | Get the head of a remote branch. -gitRemoteBranchHead :: Text -> Text -> Mit Env (Maybe Text) -gitRemoteBranchHead remote branch = - git ["rev-parse", "refs/remotes/" <> remote <> "/" <> branch] <&> \case +gitRemoteBranchHead :: Logger ProcessInfo -> Text -> Text -> IO (Maybe Text) +gitRemoteBranchHead logger remote branch = + git logger ["rev-parse", "refs/remotes/" <> remote <> "/" <> branch] <&> \case Left _ -> Nothing Right head -> Just head -gitRevParseAbsoluteGitDir :: ProcessOutput a => Mit Env a -gitRevParseAbsoluteGitDir = - git ["rev-parse", "--absolute-git-dir"] +gitRevParseAbsoluteGitDir :: Logger ProcessInfo -> IO (Maybe Text) +gitRevParseAbsoluteGitDir logger = + git logger ["rev-parse", "--absolute-git-dir"] <&> \case + Left _ -> Nothing + Right gitdir -> Just gitdir -gitShow :: Text -> Mit Env GitCommitInfo -gitShow commit = - parseGitCommitInfo - <$> git +gitShow :: Logger ProcessInfo -> Text -> IO GitCommitInfo +gitShow logger commit = + fmap parseGitCommitInfo do + git + logger [ "show", "--color=always", "--date=human", @@ -369,33 +336,36 @@ ] -- | Stash uncommitted changes (if any). -gitStash :: Mit Env (Maybe Text) -gitStash = do - gitDiff >>= \case - Differences -> do - stash <- gitCreateStash - git_ ["clean", "-d", "--force"] - gitDeleteChanges +gitStash :: Logger ProcessInfo -> IO (Maybe Text) +gitStash logger = do + gitCreateStash logger >>= \case + Nothing -> pure Nothing + Just stash -> do + git @() logger ["clean", "-d", "--force"] + git @() logger ["reset", "--hard", "--quiet", "HEAD"] pure (Just stash) - NoDifferences -> pure Nothing -gitUnstageChanges :: Mit Env () -gitUnstageChanges = do - git_ ["reset", "--quiet", "--", "."] - untrackedFiles <- gitListUntrackedFiles +gitUnstageChanges :: Logger ProcessInfo -> IO () +gitUnstageChanges logger = do + git @() logger ["reset", "--quiet", "--", "."] + untrackedFiles <- gitListUntrackedFiles logger when (not (null untrackedFiles)) do - git_ ("add" : "--intent-to-add" : untrackedFiles) + git @() logger ("add" : "--intent-to-add" : untrackedFiles) -gitVersion :: Goto Env [Stanza] -> Mit Env GitVersion -gitVersion return = do - v0 <- git ["--version"] - fromMaybe (return [Just ("Could not parse git version from: " <> Text.Builder.fromText v0)]) do - "git" : "version" : v1 : _ <- Just (Text.words v0) - [sx, sy, sz] <- Just (Text.split (== '.') v1) - x <- readMaybe (Text.unpack sx) - y <- readMaybe (Text.unpack sy) - z <- readMaybe (Text.unpack sz) - pure (pure (GitVersion x y z)) +-- | Parse the @git@ version from the output of @git --version@. +-- +-- If parsing fails, returns version @0.0.0@. +gitVersion :: Logger ProcessInfo -> IO GitVersion +gitVersion logger = do + v0 <- git logger ["--version"] + pure do + fromMaybe (GitVersion 0 0 0) do + "git" : "version" : v1 : _ <- Just (Text.words v0) + [sx, sy, sz] <- Just (Text.split (== '.') v1) + x <- readMaybe (Text.unpack sx) + y <- readMaybe (Text.unpack sy) + z <- readMaybe (Text.unpack sz) + pure (GitVersion x y z) data GitWorktree = GitWorktree { branch :: Maybe Text, @@ -404,11 +374,10 @@ prunable :: Bool } --- /dir/one 0efd393c35 [oingo] -> ("/dir/one", "0efd393c35", Just "oingo") --- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing) -gitWorktreeList :: Mit Env [GitWorktree] -gitWorktreeList = do - git ["worktree", "list"] <&> map \line -> +-- | List worktrees. +gitListWorktrees :: Logger ProcessInfo -> IO [GitWorktree] +gitListWorktrees logger = do + git logger ["worktree", "list"] <&> map \line -> case Parsec.parse parser "" line of Left err -> error (show err) Right worktree -> worktree @@ -437,7 +406,7 @@ where segmentP :: Parsec.Parsec Text () Text segmentP = - Text.pack <$> Parsec.many1 (Parsec.satisfy (not . isSpace)) + Text.pack <$> Parsec.many1 (Parsec.satisfy (not . Char.isSpace)) -- git@github.com:mitchellwrosen/mit.git -> Just ("git@github.com:mitchellwrosen/mit.git", "mit") parseGitRepo :: Text -> Maybe (Text, Text) @@ -445,8 +414,8 @@ url' <- Text.stripSuffix ".git" url pure (url, Text.takeWhileEnd (/= '/') url') -git :: ProcessOutput a => [Text] -> Mit Env a -git args = do +git :: (ProcessOutput a) => Logger ProcessInfo -> [Text] -> IO a +git logger args = do let spec :: CreateProcess spec = CreateProcess @@ -467,28 +436,37 @@ detach_console = False, use_process_jobs = False } - t0 <- io getMonotonicTime - with (bracket (createProcess spec) cleanup) \(_maybeStdin, maybeStdout, maybeStderr, processHandle) -> do - with Ki.scoped \scope -> do - stdoutThread <- io (Ki.fork scope (drainTextHandle (fromJust maybeStdout))) - stderrThread <- io (Ki.fork scope (drainTextHandle (fromJust maybeStderr))) - exitCode <- io (waitForProcess processHandle) - t1 <- io getMonotonicTime - stdoutLines <- io (atomically (Ki.await stdoutThread)) - stderrLines <- io (atomically (Ki.await stderrThread)) - debugPrintGit args stdoutLines stderrLines exitCode (t1 - t0) - io (fromProcessOutput stdoutLines stderrLines exitCode) + t0 <- getMonotonicTime + bracket (createProcess spec) cleanup \(_maybeStdin, maybeStdout, maybeStderr, processHandle) -> do + Ki.scoped \scope -> do + stdoutThread <- Ki.fork scope (drainTextHandle (fromJust maybeStdout)) + stderrThread <- Ki.fork scope (drainTextHandle (fromJust maybeStderr)) + exitCode <- waitForProcess processHandle + t1 <- getMonotonicTime + output <- atomically (Ki.await stdoutThread) + errput <- atomically (Ki.await stderrThread) + log + logger + ProcessInfo + { name = "git", + args, + output, + errput, + exitCode, + seconds = t1 - t0 + } + fromProcessOutput output errput exitCode where cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () cleanup (maybeStdin, maybeStdout, maybeStderr, process) = - void @_ @ExitCode terminate `finally` closeHandles + ignoreSyncExceptions (terminate `finally` closeHandles) where closeHandles :: IO () closeHandles = whenJust maybeStdin hClose `finally` whenJust maybeStdout hClose `finally` whenJust maybeStderr hClose - terminate :: IO ExitCode + terminate :: IO () terminate = do withProcessHandle process \case ClosedHandle _ -> pure () @@ -496,78 +474,63 @@ OpenHandle pid -> do pgid <- getProcessGroupIDOf pid signalProcessGroup sigTERM pgid - waitForProcess process + _exitCode <- waitForProcess process + pure () -git_ :: [Text] -> Mit Env () -git_ = - git +ignoreSyncExceptions :: IO () -> IO () +ignoreSyncExceptions action = + try action >>= \case + Left ex -> + case fromException ex of + Nothing -> pure () + Just (_ :: SomeAsyncException) -> throwIO ex + Right () -> pure () -- Yucky interactive/inherity variant (so 'git commit' can open an editor). -- -- FIXME bracket -git2 :: [Text] -> Mit Env ExitCode -git2 args = do - t0 <- io getMonotonicTime - (_, _, stderrHandle, processHandle) <- - io do - createProcess - CreateProcess - { child_group = Nothing, - child_user = Nothing, - close_fds = True, - cmdspec = RawCommand "git" (map Text.unpack args), - create_group = False, - cwd = Nothing, - delegate_ctlc = True, - env = Nothing, - new_session = False, - std_err = CreatePipe, - std_in = Inherit, - std_out = Inherit, - -- windows-only - create_new_console = False, - detach_console = False, - use_process_jobs = False - } - exitCode <- - io do - waitForProcess processHandle `catch` \case - UserInterrupt -> pure (ExitFailure (-130)) - exception -> throwIO exception - t1 <- io getMonotonicTime - stderrLines <- io (drainTextHandle (fromJust stderrHandle)) - debugPrintGit args Seq.empty stderrLines exitCode (t1 - t0) - pure exitCode - -debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Double -> Mit Env () -debugPrintGit args stdoutLines stderrLines exitCode sec = do - env <- getEnv - io case env.verbosity of - 1 -> Builder.putln (Text.Builder.brightBlack v1) - 2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2)) - _ -> pure () - where - v1 = - Text.Builder.bold - ( marker - <> " [" - <> Text.Builder.formatRealFloat Text.Builder.Fixed (Just 0) (sec * 1000) - <> "ms] git " - <> Builder.hcat (map quote args) - ) - v2 = foldMap (\line -> "\n " <> Text.Builder.fromText line) (stdoutLines <> stderrLines) - - quote :: Text -> Text.Builder - quote s = - if Text.any isSpace s - then Builder.squoted (Text.Builder.fromText (Text.replace "'" "\\'" s)) - else Text.Builder.fromText s - - marker :: Text.Builder - marker = - case exitCode of - ExitFailure _ -> Text.Builder.singleton '✗' - ExitSuccess -> Text.Builder.singleton '✓' +git2 :: Logger ProcessInfo -> [Text] -> IO Bool +git2 logger args = do + t0 <- getMonotonicTime + (_, _, stderrHandle, processHandle) <- do + createProcess + CreateProcess + { child_group = Nothing, + child_user = Nothing, + close_fds = True, + cmdspec = RawCommand "git" (map Text.unpack args), + create_group = False, + cwd = Nothing, + delegate_ctlc = True, + env = Nothing, + new_session = False, + std_err = CreatePipe, + std_in = Inherit, + std_out = Inherit, + -- windows-only + create_new_console = False, + detach_console = False, + use_process_jobs = False + } + exitCode <- do + waitForProcess processHandle `catch` \case + UserInterrupt -> pure (ExitFailure (-130)) + exception -> throwIO exception + t1 <- getMonotonicTime + errput <- drainTextHandle (fromJust stderrHandle) + log + logger + ProcessInfo + { name = "git", + args, + output = Seq.empty, + errput, + exitCode, + seconds = t1 - t0 + } + pure case exitCode of + ExitFailure _ -> False + ExitSuccess -> True drainTextHandle :: Handle -> IO (Seq Text) drainTextHandle handle = do diff --git a/src/Mit/Logger.hs b/src/Mit/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Logger.hs @@ -0,0 +1,27 @@ +module Mit.Logger + ( Logger, + makeLogger, + log, + ) +where + +import Mit.Prelude + +-- | A logger. +newtype Logger a + = Logger (a -> IO ()) + +instance Contravariant Logger where + contramap :: (a -> b) -> Logger b -> Logger a + contramap f (Logger g) = + Logger (g . f) + +-- | Make a logger. +makeLogger :: (a -> IO ()) -> Logger a +makeLogger = + Logger + +-- | Log with a logger. +log :: Logger a -> a -> IO () +log (Logger f) = + f diff --git a/src/Mit/Merge.hs b/src/Mit/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Merge.hs @@ -0,0 +1,46 @@ +-- | @git merge@ utilities. +module Mit.Merge + ( performMerge, + MergeResult (..), + mergeResultConflicts, + ) +where + +import Mit.Git (GitCommitInfo, GitConflict, git, gitCommitsBetween, gitConflicts, gitMergeInProgress) +import Mit.Logger (Logger) +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo) +import Mit.Seq1 qualified as Seq1 + +-- | @performMerge logger message commit@ merges @commit@ into the current branch, preferring a fast-forward. If a merge +-- commit is created, its commit message is @message@. +performMerge :: Logger ProcessInfo -> Text -> Text -> Text -> IO MergeResult +performMerge logger gitdir commit message = do + head <- git logger ["rev-parse", "HEAD"] + commits0 <- gitCommitsBetween logger (Just head) commit + case Seq1.fromSeq commits0 of + Nothing -> pure NothingToMerge + Just commits -> do + git logger ["merge", "--ff", "--no-commit", commit] >>= \case + False -> do + conflicts <- gitConflicts logger + pure (TriedToMerge commits (Seq1.unsafeFromList conflicts)) + True -> do + -- If this was a fast-forward, a merge would not be in progress at this point. + whenM (gitMergeInProgress gitdir) (git @() logger ["commit", "--message", message]) + pure (Merged commits) + +-- | The result of a 'performMerge'. Lists of commits do not contain the merge commit itself. +data MergeResult + = -- | There was nothing to merge. + NothingToMerge + | -- | We tried to merge these commits, but observed these conflicts. + TriedToMerge !(Seq1 GitCommitInfo) !(Seq1 GitConflict) + | -- | We successfully merged these commits. + Merged !(Seq1 GitCommitInfo) -- note: doesn't distinguish between FF and non-FF + +mergeResultConflicts :: MergeResult -> Maybe (Seq1 GitConflict) +mergeResultConflicts = \case + NothingToMerge -> Nothing + TriedToMerge _commits conflicts -> Just conflicts + Merged _commits -> Nothing diff --git a/src/Mit/Monad.hs b/src/Mit/Monad.hs deleted file mode 100644 --- a/src/Mit/Monad.hs +++ /dev/null @@ -1,90 +0,0 @@ -module Mit.Monad - ( Mit, - runMit, - io, - getEnv, - withEnv, - Goto, - label, - with, - with_, - ) -where - -import Control.Monad qualified -import Data.Unique -import Mit.Prelude -import Unsafe.Coerce (unsafeCoerce) - -newtype Mit r a - = Mit (forall x. r -> (a -> IO x) -> IO x) - deriving stock (Functor) - -instance Applicative (Mit r) where - pure x = Mit \_ k -> k x - (<*>) = ap - -instance Monad (Mit r) where - return = pure - Mit mx >>= f = - Mit \r k -> - mx r (\a -> unMit (f a) r k) - -instance MonadIO (Mit r) where - liftIO = io - -unMit :: Mit r a -> r -> (a -> IO x) -> IO x -unMit (Mit k) = - k - -runMit :: r -> Mit r a -> IO a -runMit r m = - unMit m r pure - -io :: IO a -> Mit r a -io m = - Mit \_ k -> do - x <- m - k x - -getEnv :: Mit r r -getEnv = - Mit \r k -> k r - -withEnv :: (r -> s) -> Mit s a -> Mit r a -withEnv f m = - Mit \r k -> unMit m (f r) k - -type Goto r a = - forall void. a -> Mit r void - -label :: (Goto r a -> Mit r a) -> Mit r a -label f = - Mit \r k -> do - n <- newUnique - try (runMit r (f (\x -> io (throwIO (X n x))))) >>= \case - Left err@(X m y) - | n == m -> k (unsafeCoerce y) - | otherwise -> throwIO err - Right x -> k x - -data X = forall a. X Unique a - -instance Exception X where - toException = asyncExceptionToException - fromException = asyncExceptionFromException - -instance Show X where - show _ = "" - -with :: (forall v. (a -> IO v) -> IO v) -> (a -> Mit r b) -> Mit r b -with f action = - Mit \r k -> do - b <- f (\a -> runMit r (action a)) - k b - -with_ :: (forall v. IO v -> IO v) -> Mit r a -> Mit r a -with_ f action = - Mit \r k -> do - a <- f (runMit r action) - k a diff --git a/src/Mit/Output.hs b/src/Mit/Output.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Output.hs @@ -0,0 +1,33 @@ +module Mit.Output + ( Output (..), + ) +where + +import Mit.Git (GitCommitInfo, GitConflict) +import Mit.Prelude + +data Output + = BranchAlreadyCheckedOut !Text !Text !Text -- branch name, where we want to check it out, where it is checked out + | CanUndo + | CheckedOutBranch !Text !Text -- branch name, directory + | CreatedBranch !Text !Text + | DirectoryAlreadyExists !Text !Text -- branch name, directory + | GitTooOld + | MergeInProgress + | MergeFailed !(Seq1 GitCommitInfo) !(Seq1 GitConflict) + | -- FIXME persist the commits that we're merging so we can report them (no more Just Nothing case) + MergeSucceeded !(Maybe (Seq1 GitCommitInfo)) + | NoGitDir + | NoSuchBranch + | NotOnBranch + | NothingToCommit + | NothingToMerge !Text !Text + | NothingToUndo + | PullFailed !(Seq1 GitCommitInfo) !(Seq1 GitConflict) + | PullSucceeded !(Seq1 GitCommitInfo) + | PushFailed !(Seq1 GitCommitInfo) + | PushSucceeded !(Seq1 GitCommitInfo) + | PushWouldBeRejected !(Seq1 GitCommitInfo) !Int + | PushWouldntReachRemote !(Seq1 GitCommitInfo) + | UnstashFailed !(Seq1 GitConflict) + | UpstreamIsAhead !Int diff --git a/src/Mit/Prelude.hs b/src/Mit/Prelude.hs --- a/src/Mit/Prelude.hs +++ b/src/Mit/Prelude.hs @@ -10,14 +10,17 @@ import Control.Exception as X hiding (handle, throw) import Control.Monad as X hiding (return) import Control.Monad.IO.Class as X (MonadIO (..)) -import Data.Char as X -import Data.Foldable as X +import Data.Char qualified as Char +import Data.Coerce as X (coerce) +import Data.Foldable as X (asum, fold, for_, toList) import Data.Function as X import Data.Functor as X (($>)) +import Data.Functor.Contravariant as X (Contravariant, contramap, (>$<)) import Data.IORef as X import Data.List.NonEmpty qualified as List1 import Data.Map as X (Map) import Data.Maybe as X +import Data.Semigroup as X (sconcat) import Data.Sequence as X (Seq) import Data.Set as X (Set) import Data.Text as X (Text) @@ -29,12 +32,12 @@ import GHC.Stack as X (HasCallStack) import Mit.Seq1 as X (Seq1) import Text.Read as X (readMaybe) -import Prelude as X hiding (head, id, return) +import Prelude as X hiding (head, id, lines, log, return) type List1 = List1.NonEmpty -(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) :: (Functor f) => f a -> (a -> b) -> f b (<&>) = flip fmap @@ -53,37 +56,51 @@ quoteText :: Text -> Text quoteText s = - if Text.any isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s + if Text.any Char.isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s -- FIXME make this faster text2word64 :: Text -> Maybe Word64 text2word64 = readMaybe . Text.unpack -onLeftM :: Monad m => (a -> m b) -> m (Either a b) -> m b +onLeftM :: (Monad m) => (a -> m b) -> m (Either a b) -> m b onLeftM mx my = my >>= either mx pure -onNothingM :: Monad m => m a -> m (Maybe a) -> m a +onJustM :: (Monad m) => (a -> m ()) -> m (Maybe a) -> m () +onJustM f mx = + mx >>= maybe (pure ()) f + +onNothing :: (Applicative m) => m a -> Maybe a -> m a +onNothing mx = + maybe mx pure + +onNothingM :: (Monad m) => m a -> m (Maybe a) -> m a onNothingM mx my = my >>= maybe mx pure -unlessM :: Monad m => m Bool -> m () -> m () +unlessM :: (Monad m) => m Bool -> m () -> m () unlessM mx action = mx >>= \case False -> action True -> pure () -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m () whenJust = for_ -whenM :: Monad m => m Bool -> m () -> m () +whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m () +whenJustM mx action = + mx >>= \case + Nothing -> pure () + Just x -> action x + +whenM :: (Monad m) => m Bool -> m () -> m () whenM mx action = mx >>= \case False -> pure () True -> action -whenNotM :: Monad m => m Bool -> m () -> m () +whenNotM :: (Monad m) => m Bool -> m () -> m () whenNotM mx = whenM (not <$> mx) diff --git a/src/Mit/Pretty.hs b/src/Mit/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Pretty.hs @@ -0,0 +1,115 @@ +module Mit.Pretty + ( Pretty, + Line, + put, + empty, + line, + lines, + paragraphs, + Mit.Pretty.when, + Mit.Pretty.whenJust, + indent, + style, + char, + text, + builder, + int, + -- + branch, + command, + directory, + ) +where + +import Data.List qualified as List +import Data.String (IsString (..)) +import Data.Text qualified as Text +import Data.Text.Builder.Linear qualified as Text (Builder) +import Data.Text.Builder.Linear qualified as Text.Builder +import Data.Text.IO qualified as Text +import Mit.Prelude +import Text.Builder.ANSI qualified as Text.Builder + +type Pretty = + [Line] + +newtype Line + = Line Text.Builder + deriving newtype (Semigroup) + +instance IsString Line where + fromString = + builder . fromString + +put :: Pretty -> IO () +put = do + f . coerce (Text.Builder.runBuilder . fold . List.intersperse (Text.Builder.fromChar '\n')) + where + f :: Text -> IO () + f t = + Mit.Prelude.when (not (Text.null t)) (Text.putStrLn t) + +empty :: Pretty +empty = + [] + +line :: Line -> Pretty +line x = + [x] + +lines :: [Line] -> Pretty +lines = + id + +paragraphs :: [Pretty] -> Pretty +paragraphs = + fold . List.intersperse (line (char ' ')) . filter (not . null) + +when :: Bool -> Pretty -> Pretty +when = \case + False -> const empty + True -> id + +whenJust :: Maybe a -> (a -> Pretty) -> Pretty +whenJust = \case + Nothing -> const empty + Just x -> \f -> f x + +indent :: Int -> Pretty -> Pretty +indent n = + -- FIXME more efficient pad? + map (builder (fold (replicate n (Text.Builder.fromChar ' '))) <>) + +style :: (Text.Builder -> Text.Builder) -> Line -> Line +style = + coerce + +char :: Char -> Line +char = + builder . Text.Builder.fromChar + +text :: Text -> Line +text = + builder . Text.Builder.fromText + +builder :: Text.Builder -> Line +builder = + coerce + +int :: Int -> Line +int = + builder . Text.Builder.fromDec + +--- + +branch :: Text -> Line +branch = + builder . Text.Builder.italic . Text.Builder.fromText + +command :: Text -> Line +command = + builder . Text.Builder.bold . Text.Builder.blue . Text.Builder.fromText + +directory :: Text -> Line +directory = + builder . Text.Builder.bold . Text.Builder.fromText diff --git a/src/Mit/Process.hs b/src/Mit/Process.hs --- a/src/Mit/Process.hs +++ b/src/Mit/Process.hs @@ -13,26 +13,31 @@ fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO a instance ProcessOutput () where + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO () fromProcessOutput _ _ code = when (code /= ExitSuccess) (exitWith code) instance ProcessOutput Bool where + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO Bool fromProcessOutput _ _ = \case ExitFailure _ -> pure False ExitSuccess -> pure True instance ProcessOutput Text where + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO Text fromProcessOutput out _ code = do when (code /= ExitSuccess) (exitWith code) case out of Seq.Empty -> throwIO (userError "no stdout") line Seq.:<| _ -> pure line -instance a ~ Text => ProcessOutput [a] where +instance (a ~ Text) => ProcessOutput [a] where + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO [Text] fromProcessOutput out err code = toList @Seq <$> fromProcessOutput out err code -instance a ~ ExitCode => ProcessOutput (Either a Text) where +instance (a ~ ExitCode) => ProcessOutput (Either a Text) where + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO (Either ExitCode Text) fromProcessOutput out _ code = case code of ExitFailure _ -> pure (Left code) @@ -41,14 +46,8 @@ Seq.Empty -> throwIO (userError "no stdout") line Seq.:<| _ -> pure (Right line) -instance a ~ Text => ProcessOutput (Maybe a) where - fromProcessOutput out _ code = do - when (code /= ExitSuccess) (exitWith code) - case out of - Seq.Empty -> pure Nothing - line Seq.:<| _ -> pure (Just line) - -instance a ~ Text => ProcessOutput (Seq a) where +instance (a ~ Text) => ProcessOutput (Seq a) where + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO (Seq Text) fromProcessOutput out _ code = do when (code /= ExitSuccess) (exitWith code) pure out diff --git a/src/Mit/ProcessInfo.hs b/src/Mit/ProcessInfo.hs new file mode 100644 --- /dev/null +++ b/src/Mit/ProcessInfo.hs @@ -0,0 +1,17 @@ +module Mit.ProcessInfo + ( ProcessInfo (..), + ) +where + +import Mit.Prelude +import System.Exit (ExitCode) + +-- | Information about a completed process. +data ProcessInfo = ProcessInfo + { name :: !Text, + args :: ![Text], + output :: !(Seq Text), + errput :: !(Seq Text), + exitCode :: !ExitCode, + seconds :: !Double + } diff --git a/src/Mit/Push.hs b/src/Mit/Push.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Push.hs @@ -0,0 +1,52 @@ +module Mit.Push + ( performPush, + PushResult (..), + DidntPushReason (..), + pushResultPushed, + ) +where + +import Mit.Git (GitCommitInfo, git, gitCommitsBetween, gitNumCommitsBetween) +import Mit.Logger (Logger) +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo) +import Mit.Seq1 qualified as Seq1 +import UnconditionalJump (goto, label) + +performPush :: Logger ProcessInfo -> Text -> Maybe Text -> Maybe Text -> Bool -> IO PushResult +performPush logger branch maybeHead maybeUpstreamHead fetched = do + label \done -> do + head <- maybeHead & onNothing (goto done (DidntPush NothingToPush)) + commits <- gitCommitsBetween logger maybeUpstreamHead head + commits1 <- Seq1.fromSeq commits & onNothing (goto done (DidntPush NothingToPush)) + numRemoteCommits <- + case maybeUpstreamHead of + Nothing -> pure 0 + Just upstreamHead -> gitNumCommitsBetween logger head upstreamHead + when (numRemoteCommits > 0) (goto done (DidntPush (PushWouldBeRejected commits1 numRemoteCommits))) + when (not fetched) (goto done (DidntPush (PushWouldntReachRemote commits1))) + git logger ["push", "--follow-tags", "--set-upstream", "origin", "--quiet", branch <> ":" <> branch] <&> \case + False -> DidntPush (TriedToPush commits1) + True -> Pushed commits1 + +-- | The result of (considering a) git push. +data PushResult + = -- | We didn't push anthing. + DidntPush !DidntPushReason + | -- | We successfully pushed commits. + Pushed !(Seq1 GitCommitInfo) + +data DidntPushReason + = -- | There was nothing to push (or the user explicitly asked to not push). + NothingToPush + | -- | We have commits to push, but we appear to be offline. + PushWouldntReachRemote !(Seq1 GitCommitInfo) + | -- | We have commits to push, but there are also remote commits to merge. + PushWouldBeRejected !(Seq1 GitCommitInfo) !Int + | -- | We had commits to push, and tried to push, but it failed. + TriedToPush !(Seq1 GitCommitInfo) + +pushResultPushed :: PushResult -> Bool +pushResultPushed = \case + DidntPush _ -> False + Pushed _ -> True diff --git a/src/Mit/Seq1.hs b/src/Mit/Seq1.hs --- a/src/Mit/Seq1.hs +++ b/src/Mit/Seq1.hs @@ -1,46 +1,65 @@ module Mit.Seq1 - ( Seq1, + ( Seq1 (Cons, Snoc), + Mit.Seq1.length, + last, + dropEnd, + fromList, + unsafeFromList, fromSeq, unsafeFromSeq, toSeq, toList, - Mit.Seq1.length, - dropEnd, + toList1, ) where -import Data.Coerce +import Data.Coerce (coerce) import Data.Foldable qualified +import Data.Foldable qualified as Foldable +import Data.Foldable1 (Foldable1 (foldMap1, foldMap1')) +import Data.List.NonEmpty qualified as List (NonEmpty) +import Data.List.NonEmpty qualified as List.NonEmpty import Data.Maybe (fromMaybe) import Data.Sequence (Seq) import Data.Sequence qualified as Seq import GHC.Stack (HasCallStack) -import Prelude +import Prelude hiding (last) newtype Seq1 a = Seq1 (Seq a) deriving newtype (Foldable) -fromSeq :: Seq a -> Maybe (Seq1 a) -fromSeq = \case - Seq.Empty -> Nothing - xs -> Just (Seq1 xs) +pattern Cons :: a -> Seq a -> Seq1 a +pattern Cons x xs <- Seq1 (x Seq.:<| xs) -unsafeFromSeq :: HasCallStack => Seq a -> Seq1 a -unsafeFromSeq = - fromMaybe (error "unsafeFromSeq: empty sequence") . fromSeq +{-# COMPLETE Cons #-} -toSeq :: Seq1 a -> Seq a -toSeq = - coerce +pattern Snoc :: Seq a -> a -> Seq1 a +pattern Snoc xs x <- Seq1 (xs Seq.:|> x) -toList :: forall a. Seq1 a -> [a] -toList = - coerce (Data.Foldable.toList @Seq @a) +{-# COMPLETE Snoc #-} +instance Foldable1 Seq1 where + foldMap1 :: (Semigroup m) => (a -> m) -> Seq1 a -> m + foldMap1 f (Cons x xs) = + go (f x) (Foldable.toList xs) + where + go y = \case + [] -> y + z : zs -> y <> go (f z) zs + + foldMap1' :: (Semigroup m) => (a -> m) -> Seq1 a -> m + foldMap1' f (Cons x xs) = + Foldable.foldl' (\acc y -> acc <> f y) (f x) xs + length :: forall a. Seq1 a -> Int length = coerce (Seq.length @a) +last :: Seq1 a -> a +last = \case + Seq1 Seq.Empty -> undefined + Seq1 (_ Seq.:|> x) -> x + dropEnd :: Int -> Seq1 a -> Seq a dropEnd = let loop :: Int -> Seq a -> Seq a @@ -51,3 +70,33 @@ Seq.Empty -> Seq.Empty ys Seq.:|> _ -> loop (n - 1) ys in \n (Seq1 xs) -> loop n xs + +fromList :: [a] -> Maybe (Seq1 a) +fromList = \case + [] -> Nothing + xs -> Just (Seq1 (Seq.fromList xs)) + +unsafeFromList :: (HasCallStack) => [a] -> Seq1 a +unsafeFromList = + fromMaybe (error "unsafeFromList: empty list") . fromList + +fromSeq :: Seq a -> Maybe (Seq1 a) +fromSeq = \case + Seq.Empty -> Nothing + xs -> Just (Seq1 xs) + +unsafeFromSeq :: (HasCallStack) => Seq a -> Seq1 a +unsafeFromSeq = + fromMaybe (error "unsafeFromSeq: empty sequence") . fromSeq + +toSeq :: Seq1 a -> Seq a +toSeq = + coerce + +toList :: forall a. Seq1 a -> [a] +toList = + coerce @(Seq a -> [a]) Data.Foldable.toList + +toList1 :: Seq1 a -> List.NonEmpty a +toList1 = + List.NonEmpty.fromList . Data.Foldable.toList diff --git a/src/Mit/Snapshot.hs b/src/Mit/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Snapshot.hs @@ -0,0 +1,40 @@ +module Mit.Snapshot + ( Snapshot, + snapshotStash, + undoToSnapshot, + performSnapshot, + ) +where + +import Mit.Git (gitCreateStash, gitMaybeHead) +import Mit.Logger (Logger) +import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo) +import Mit.Undo (Undo (..)) + +-- | The snapshot of a git repository. +data Snapshot + = Empty -- empty repo + | Clean !Text -- head + | Dirty !Text !Text -- head, stash + +snapshotStash :: Snapshot -> Maybe Text +snapshotStash = \case + Empty -> Nothing + Clean _head -> Nothing + Dirty _head stash -> Just stash + +undoToSnapshot :: Snapshot -> Maybe Undo +undoToSnapshot = \case + Empty -> Nothing + Clean head -> Just (Reset head) + Dirty head stash -> Just (ResetApply head stash) + +performSnapshot :: Logger ProcessInfo -> IO Snapshot +performSnapshot pinfo = + gitMaybeHead pinfo >>= \case + Nothing -> pure Empty + Just head -> + gitCreateStash pinfo <&> \case + Nothing -> Clean head + Just stash -> Dirty head stash diff --git a/src/Mit/Stanza.hs b/src/Mit/Stanza.hs deleted file mode 100644 --- a/src/Mit/Stanza.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Mit.Stanza - ( Stanza, - renderStanzas, - putStanzas, - ) -where - -import Data.List qualified as List -import Data.Text.IO qualified as Text -import Data.Text.Lazy.Builder qualified as Text (Builder) -import Mit.Builder qualified as Builder -import Mit.Prelude - -type Stanza = - Maybe Text.Builder - -renderStanzas :: [Stanza] -> Stanza -renderStanzas stanzas = - case catMaybes stanzas of - [] -> Nothing - stanzas' -> Just (mconcat (List.intersperse (Builder.newline <> Builder.newline) stanzas')) - -putStanzas :: [Stanza] -> IO () -putStanzas stanzas = - whenJust (renderStanzas stanzas) \s -> - Text.putStr (Builder.build (Builder.newline <> s <> Builder.newline <> Builder.newline)) diff --git a/src/Mit/State.hs b/src/Mit/State.hs --- a/src/Mit/State.hs +++ b/src/Mit/State.hs @@ -1,6 +1,5 @@ module Mit.State ( MitState (..), - emptyMitState, deleteMitState, readMitState, writeMitState, @@ -10,30 +9,22 @@ import Data.Text qualified as Text import Data.Text.Encoding.Base64 qualified as Text import Data.Text.IO qualified as Text -import Mit.Env (Env (..)) -import Mit.Git -import Mit.Monad import Mit.Prelude -import Mit.Undo +import Mit.Undo (Undo (..), parseUndo, renderUndo) import System.Directory (removeFile) +import UnconditionalJump (goto, label) -data MitState a = MitState - { head :: a, - merging :: Maybe Text, - undos :: [Undo] +data MitState = MitState + { head :: !Text, + merging :: !(Maybe Text), + undo :: !(Maybe Undo) } - deriving stock (Eq, Show) -emptyMitState :: MitState () -emptyMitState = - MitState {head = (), merging = Nothing, undos = []} - -deleteMitState :: Text -> Mit Env () -deleteMitState branch64 = do - mitfile <- getMitfile branch64 - io (removeFile mitfile `catch` \(_ :: IOException) -> pure ()) +deleteMitState :: Text -> Text -> IO () +deleteMitState gitdir branch64 = do + removeFile (makeMitfile gitdir branch64) `catch` \(_ :: IOException) -> pure () -parseMitState :: Text -> Maybe (MitState Text) +parseMitState :: Text -> Maybe MitState parseMitState contents = do [headLine, mergingLine, undosLine] <- Just (Text.lines contents) ["head", head] <- Just (Text.words headLine) @@ -42,49 +33,46 @@ ["merging"] -> Just Nothing ["merging", branch] -> Just (Just branch) _ -> Nothing - undos <- Text.stripPrefix "undos " undosLine >>= parseUndos - pure MitState {head, merging, undos} + undo <- do + undosLine1 <- Text.stripPrefix "undo " undosLine + if Text.null undosLine1 + then Just Nothing + else Just <$> parseUndo undosLine1 + pure MitState {head, merging, undo} -readMitState :: Text -> Mit Env (MitState ()) -readMitState branch = +readMitState :: Text -> Text -> Text -> IO (Maybe MitState) +readMitState gitdir branch head = do label \return -> do - head <- - gitMaybeHead >>= \case - Nothing -> return emptyMitState - Just head -> pure head - mitfile <- getMitfile branch64 + let mitfile = makeMitfile gitdir branch64 contents <- - io (try (Text.readFile mitfile)) >>= \case - Left (_ :: IOException) -> return emptyMitState + try (Text.readFile mitfile) >>= \case + Left (_ :: IOException) -> goto return Nothing Right contents -> pure contents let maybeState = do state <- parseMitState contents guard (head == state.head) pure state - state <- - case maybeState of - Nothing -> do - deleteMitState branch64 - return emptyMitState - Just state -> pure state - pure (state {head = ()} :: MitState ()) + case maybeState of + Nothing -> do + deleteMitState gitdir branch64 + goto return Nothing + Just state -> pure (Just state) where branch64 = Text.encodeBase64 branch -writeMitState :: Text -> MitState () -> Mit Env () -writeMitState branch state = do - head <- gitHead - let contents :: Text - contents = - Text.unlines - [ "head " <> head, - "merging " <> fromMaybe Text.empty state.merging, - "undos " <> showUndos state.undos - ] - mitfile <- getMitfile (Text.encodeBase64 branch) - io (Text.writeFile mitfile contents `catch` \(_ :: IOException) -> pure ()) +writeMitState :: Text -> Text -> MitState -> IO () +writeMitState gitdir branch state = do + let mitfile = makeMitfile gitdir (Text.encodeBase64 branch) + Text.writeFile mitfile contents `catch` \(_ :: IOException) -> pure () + where + contents :: Text + contents = + Text.unlines + [ "head " <> state.head, + "merging " <> fromMaybe Text.empty state.merging, + "undo " <> maybe Text.empty renderUndo state.undo + ] -getMitfile :: Text -> Mit Env FilePath -getMitfile branch64 = do - gitdir <- gitRevParseAbsoluteGitDir - pure (Text.unpack (gitdir <> "/.mit-" <> branch64)) +makeMitfile :: Text -> Text -> FilePath +makeMitfile gitdir branch64 = do + Text.unpack (gitdir <> "/.mit-" <> branch64) diff --git a/src/Mit/TextUtils.hs b/src/Mit/TextUtils.hs new file mode 100644 --- /dev/null +++ b/src/Mit/TextUtils.hs @@ -0,0 +1,19 @@ +-- | Random text-related utilities. +module Mit.TextUtils + ( commaSeparated, + ) +where + +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Data.Text.Builder.Linear qualified as Text.Builder +import Mit.Prelude + +-- >>> commaSeparated (Seq.fromList ["foo", "bar", "baz"]) +-- "foo,bar,baz" +commaSeparated :: Seq Text -> Text +commaSeparated = \case + Seq.Empty -> Text.empty + xs Seq.:|> x -> + Text.Builder.runBuilder $ + foldr (\y ys -> Text.Builder.fromText y <> Text.Builder.fromChar ',' <> ys) (Text.Builder.fromText x) xs diff --git a/src/Mit/Undo.hs b/src/Mit/Undo.hs --- a/src/Mit/Undo.hs +++ b/src/Mit/Undo.hs @@ -1,58 +1,71 @@ --- TODO replace with Git.Command module Mit.Undo ( Undo (..), - showUndos, - parseUndos, + undoStash, + renderUndo, + parseUndo, applyUndo, - undosStash, ) where import Data.Text qualified as Text -import Mit.Env (Env) -import Mit.Git -import Mit.Monad +import Mit.Git (git, gitUnstageChanges) +import Mit.Logger (Logger) import Mit.Prelude +import Mit.ProcessInfo (ProcessInfo) data Undo - = Apply Text -- apply stash - | Reset Text -- reset to commit - | Revert Text -- revert commit - deriving stock (Eq, Show) + = Reset !Text + | ResetApply !Text !Text + | Revert !Text + | RevertApply !Text !Text -showUndos :: [Undo] -> Text -showUndos = - Text.intercalate " " . map showUndo +undoStash :: Undo -> Maybe Text +undoStash = \case + Reset _ -> Nothing + ResetApply _ commit -> Just commit + Revert _ -> Nothing + RevertApply _ commit -> Just commit + +renderUndo :: Undo -> Text +renderUndo = + Text.unwords . f where - showUndo :: Undo -> Text - showUndo = \case - Apply commit -> "apply/" <> commit - Reset commit -> "reset/" <> commit - Revert commit -> "revert/" <> commit + f :: Undo -> [Text] + f = \case + Reset commit -> ["reset", commit] + ResetApply commit1 commit2 -> ["reset", commit1, "apply", commit2] + Revert commit -> ["revert", commit] + RevertApply commit1 commit2 -> ["revert", commit1, "apply", commit2] -parseUndos :: Text -> Maybe [Undo] -parseUndos = do - Text.words >>> traverse parseUndo +parseUndo :: Text -> Maybe Undo +parseUndo = + f . Text.words where - parseUndo :: Text -> Maybe Undo - parseUndo text = - asum - [ Apply <$> Text.stripPrefix "apply/" text, - Reset <$> Text.stripPrefix "reset/" text, - Revert <$> Text.stripPrefix "revert/" text, - error (show text) - ] + f :: [Text] -> Maybe Undo + f = \case + ["reset", commit1, "apply", commit2] -> Just (ResetApply commit1 commit2) + ["reset", commit] -> Just (Reset commit) + ["revert", commit1, "apply", commit2] -> Just (RevertApply commit1 commit2) + ["revert", commit] -> Just (Revert commit) + _ -> Nothing -applyUndo :: Undo -> Mit Env () -applyUndo = \case - Apply commit -> do - git_ ["stash", "apply", "--quiet", commit] - gitUnstageChanges - Reset commit -> do - git_ ["clean", "-d", "--force"] - git ["reset", "--hard", commit] - Revert commit -> git_ ["revert", commit] +applyUndo :: Logger ProcessInfo -> Undo -> IO () +applyUndo logger = \case + Reset commit -> applyReset commit + ResetApply commit1 commit2 -> do + applyReset commit1 + applyApply commit2 + Revert commit -> applyRevert commit + RevertApply commit1 commit2 -> do + applyRevert commit1 + applyApply commit2 + where + applyApply commit = do + git @() logger ["stash", "apply", "--quiet", commit] + gitUnstageChanges logger -undosStash :: [Undo] -> Maybe Text -undosStash undos = - listToMaybe [commit | Apply commit <- undos] + applyReset commit = do + git @() logger ["clean", "-d", "--force"] + git @() logger ["reset", "--hard", commit] + + applyRevert commit = git @() logger ["revert", commit] diff --git a/src/Mit/Verbosity.hs b/src/Mit/Verbosity.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Verbosity.hs @@ -0,0 +1,18 @@ +module Mit.Verbosity + ( Verbosity (..), + intToVerbosity, + ) +where + +import Mit.Prelude + +data Verbosity + = V0 + | V1 + | V2 + +intToVerbosity :: Int -> Verbosity +intToVerbosity n + | n <= 0 = V0 + | n == 1 = V1 + | otherwise = V2