mit-3qvpPyAi6mH 11 → 12
raw patch · 28 files changed
+1950/−1456 lines, 28 filesdep +text-builder-lineardep +unconditional-jumpdep ~basedep ~containersdep ~directory
Dependencies added: text-builder-linear, unconditional-jump
Dependency ranges changed: base, containers, directory, ki, parsec, process, stm, text, text-ansi, unix
Files
- mit-3qvpPyAi6mH.cabal +32/−15
- src/Mit.hs +494/−847
- src/Mit/Builder.hs +0/−58
- src/Mit/Command/Branch.hs +75/−0
- src/Mit/Command/Commit.hs +253/−0
- src/Mit/Command/Merge.hs +111/−0
- src/Mit/Command/Status.hs +16/−0
- src/Mit/Command/Sync.hs +126/−0
- src/Mit/Command/Undo.hs +38/−0
- src/Mit/Directory.hs +5/−6
- src/Mit/Env.hs +0/−10
- src/Mit/Git.hs +233/−270
- src/Mit/Logger.hs +27/−0
- src/Mit/Merge.hs +46/−0
- src/Mit/Monad.hs +0/−90
- src/Mit/Output.hs +33/−0
- src/Mit/Prelude.hs +28/−11
- src/Mit/Pretty.hs +115/−0
- src/Mit/Process.hs +9/−10
- src/Mit/ProcessInfo.hs +17/−0
- src/Mit/Push.hs +52/−0
- src/Mit/Seq1.hs +67/−18
- src/Mit/Snapshot.hs +40/−0
- src/Mit/Stanza.hs +0/−26
- src/Mit/State.hs +41/−53
- src/Mit/TextUtils.hs +19/−0
- src/Mit/Undo.hs +55/−42
- src/Mit/Verbosity.hs +18/−0
mit-3qvpPyAi6mH.cabal view
@@ -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
src/Mit.hs view
@@ -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 <branch>`, so we'll have a `state0.merging`- -- that tells us we're merging in <branch>. But we also handle the case that we went `git merge` -> `mit commit`,- -- because why not.- case context.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 <file>` 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"
− src/Mit/Builder.hs
@@ -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
+ src/Mit/Command/Branch.hs view
@@ -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)
+ src/Mit/Command/Commit.hs view
@@ -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 <branch>`, so we'll have a `state0.merging`+ -- that tells us we're merging in <branch>. But we also handle the case that we went `git merge` -> `mit commit`,+ -- because why not.+ case 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)
+ src/Mit/Command/Merge.hs view
@@ -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)
+ src/Mit/Command/Status.hs view
@@ -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))
+ src/Mit/Command/Sync.hs view
@@ -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)
+ src/Mit/Command/Undo.hs view
@@ -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
src/Mit/Directory.hs view
@@ -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
− src/Mit/Env.hs
@@ -1,10 +0,0 @@-module Mit.Env- ( Env (..),- )-where--import Mit.Prelude--data Env = Env- { verbosity :: Int- }
src/Mit/Git.hs view
@@ -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
+ src/Mit/Logger.hs view
@@ -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
+ src/Mit/Merge.hs view
@@ -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
− src/Mit/Monad.hs
@@ -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
+ src/Mit/Output.hs view
@@ -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
src/Mit/Prelude.hs view
@@ -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)
+ src/Mit/Pretty.hs view
@@ -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
src/Mit/Process.hs view
@@ -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
+ src/Mit/ProcessInfo.hs view
@@ -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+ }
+ src/Mit/Push.hs view
@@ -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
src/Mit/Seq1.hs view
@@ -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
+ src/Mit/Snapshot.hs view
@@ -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
− src/Mit/Stanza.hs
@@ -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))
src/Mit/State.hs view
@@ -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)
+ src/Mit/TextUtils.hs view
@@ -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
src/Mit/Undo.hs view
@@ -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]
+ src/Mit/Verbosity.hs view
@@ -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