packages feed

mit-3qvpPyAi6mH 6 → 7

raw patch · 9 files changed

+556/−289 lines, 9 files

Files

mit-3qvpPyAi6mH.cabal view
@@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX-version: 6+version: 7  description:   A git wrapper with a streamlined UX.@@ -21,6 +21,10 @@   This package's library component does not follow the Package Versioning Policy, and is only exposed for the test   suite. +source-repository head+  type: git+  location: https://github.com/mitchellwrosen/mit.git+ common component   build-depends:     base == 4.14.3.0,@@ -64,10 +68,11 @@   import: component   exposed-modules:     Mit+    Mit.Builder     Mit.Clock+    Mit.Config     Mit.Directory     Mit.Git-    Mit.Globals     Mit.Prelude     Mit.Process     Mit.Seq
src/Mit.hs view
@@ -1,5 +1,6 @@ module Mit where +import qualified Data.List as List import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as List1 import qualified Data.Sequence as Seq@@ -8,9 +9,9 @@ import qualified Data.Text.Builder.ANSI as Text.Builder import qualified Data.Text.Encoding.Base64 as Text import qualified Data.Text.IO as Text-import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text (Builder) import qualified Data.Text.Lazy.Builder as Text.Builder+import qualified Mit.Builder as Builder import Mit.Clock (getCurrentTime) import Mit.Directory import Mit.Git@@ -37,6 +38,8 @@ -- TODO recommend merging master if it conflicts -- TODO mit log -- TODO optparse-applicative+-- TODO undo revert+-- TODO more specific "undo this change" wording  main :: IO () main = do@@ -108,7 +111,7 @@   gitBranchWorktreeDir branch >>= \case     Nothing -> do       whenM (doesDirectoryExist worktreeDir) (die ["Directory " <> Text.bold worktreeDir <> " already exists."])-      gitl_ ["worktree", "add", "--detach", worktreeDir]+      git_ ["worktree", "add", "--detach", worktreeDir]       withCurrentDirectory worktreeDir do         whenNotM (gitSwitch branch) do           gitBranch branch@@ -116,8 +119,8 @@           gitFetch_ "origin"           whenM (gitRemoteBranchExists "origin" branch) do             let upstream = "origin/" <> branch-            gitl_ ["reset", "--hard", upstream]-            gitl_ ["branch", "--set-upstream-to", upstream]+            git_ ["reset", "--hard", upstream]+            git_ ["branch", "--set-upstream-to", upstream]     Just directory ->       when (directory /= worktreeDir) do         die [Text.bold branch <> " is already checked out in " <> Text.bold directory <> "."]@@ -139,55 +142,95 @@  mitCommit_ :: IO () mitCommit_ = do-  fetched <- gitFetch "origin"   branch <- gitCurrentBranch   let branch64 = Text.encodeBase64 branch-  head <- gitHead-  maybeUpstreamHead <- gitRemoteBranchHead "origin" branch-  existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head) maybeUpstreamHead-  existLocalCommits <- maybe (pure True) (\upstreamHead -> gitExistCommitsBetween upstreamHead "HEAD") maybeUpstreamHead+  let upstream = "origin/" <> branch+  head0 <- gitHead   state0 <- readMitState branch64-   stash <- gitCreateStash+  let undos0 = [Reset head0, Apply stash] -  let wouldFork = existRemoteCommits && not existLocalCommits+  (fetched, maybeUpstreamHead, existRemoteCommits, wouldFork) <- do+    ago <- mitStateRanCommitAgo state0+    if ago < 10_000_000_000+      then do+        maybeUpstreamHead <- gitRemoteBranchHead "origin" branch+        pure (True, maybeUpstreamHead, True, True)+      else do+        fetched <- gitFetch "origin"+        maybeUpstreamHead <- gitRemoteBranchHead "origin" branch -  let shouldWarnAboutFork =-        if wouldFork-          then do-            ago <- mitStateRanCommitAgo state0-            if ago < 10_000_000_000-              then pure False-              else do-                git_ ["reset", "--hard", fromJust maybeUpstreamHead]-                canMergeCleanly <- git ["stash", "apply", stash]-                git_ ["reset", "--hard", head]-                git_ ["stash", "apply", stash]-                gitUnstageChanges-                pure canMergeCleanly-          else pure False+        existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head0) maybeUpstreamHead+        existLocalCommits <-+          maybe+            (pure True)+            (\upstreamHead -> gitExistCommitsBetween upstreamHead head0)+            maybeUpstreamHead -  -- Bail out early if we should warn that this commit would fork history-  whenM shouldWarnAboutFork do-    ranCommitAt <- Just <$> getCurrentTime-    writeMitState branch64 state0 {ranCommitAt}-    putLines-      [ "",-        "  " <> Text.yellow (Text.italic branch <> " is not up-to-date."),-        "",-        "  Run " <> Text.bold (Text.blue "mit sync") <> " first, or run " <> Text.bold (Text.blue "mit commit")-          <> " again to record a commit anyway.",-        ""-      ]-    exitFailure+        let wouldFork = existRemoteCommits && not existLocalCommits +        when wouldFork do+          applyUndo (Reset (fromJust maybeUpstreamHead))+          conflicts <- gitApplyStash stash+          for_ undos0 applyUndo++          ranCommitAt <- Just <$> getCurrentTime+          writeMitState branch64 state0 {ranCommitAt}++          putStanzas $+            case List1.nonEmpty conflicts of+              Nothing ->+                [ notSynchronizedStanza+                    (Text.Builder.fromText branch)+                    (Text.Builder.fromText upstream)+                    ", but committing these changes would not put it in conflict.",+                  Just+                    ( "  To avoid making a merge commit, run "+                        <> Text.Builder.bold (Text.Builder.blue "mit sync")+                        <> " first."+                    ),+                  Just+                    ( "  Otherwise, run "+                        <> Text.Builder.bold (Text.Builder.blue "mit commit")+                        <> " again (within 10 seconds) to record a commit anyway."+                    )+                ]+              Just conflicts1 ->+                [ notSynchronizedStanza+                    (Text.Builder.fromText branch)+                    (Text.Builder.fromText upstream)+                    ", and committing these changes would put it in conflict.",+                  conflictsStanza "These files would be in conflict:" conflicts1,+                  Just+                    ( Builder.vcat+                        [ "  To avoid making a merge commit, run "+                            <> Text.Builder.bold (Text.Builder.blue "mit sync")+                            <> " first to resolve conflicts.",+                          "  (If conflicts seem too difficult to resolve, you will be able to "+                            <> Text.Builder.bold (Text.Builder.blue "mit undo")+                            <> " to back out)."+                        ]+                    ),+                  Just+                    ( "  Otherwise, run "+                        <> Text.Builder.bold (Text.Builder.blue "mit commit")+                        <> " again (within 10 seconds) to record a commit anyway."+                    )+                ]+          exitFailure++        pure (fetched, maybeUpstreamHead, existRemoteCommits, wouldFork)+   committed <- gitCommit-  localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD"+  head1 <- if committed then gitHead else pure head0+  localCommits <- gitCommitsBetween maybeUpstreamHead head1    pushResult <-     case (localCommits, existRemoteCommits, fetched) of       (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush)-      (Seq.NonEmpty, True, _) -> pure (PushNotAttempted ForkedHistory)+      (Seq.NonEmpty, True, _) -> do+        conflicts <- gitConflictsWith (fromJust maybeUpstreamHead)+        pure (PushNotAttempted (ForkedHistory conflicts))       (Seq.NonEmpty, False, False) -> pure (PushNotAttempted Offline)       (Seq.NonEmpty, False, True) -> PushAttempted <$> gitPush branch @@ -205,38 +248,51 @@   undos <-     case (pushed, committed, localCommits) of       (False, False, _) -> pure state0.undos-      (False, True, _) -> pure [Reset head, Apply stash]-      (True, True, Seq.Singleton) -> do-        head1 <- gitHead-        pure [Revert head1, Apply stash]+      (False, True, _) -> pure undos0+      (True, True, Seq.Singleton) -> pure [Revert head1, Apply stash]       _ -> pure []    writeMitState branch64 MitState {head = (), merging = Nothing, ranCommitAt, undos} -  putSummary-    Summary-      { branch,-        -- Whether we "can undo" from here is not exactly if the state says we can undo, because of one corner case:-        -- we ran 'mit commit', then aborted the commit, and ultimately didn't push any other local changes.-        ---        -- In this case, the underlying state hasn't changed, so 'mit undo' will still work as if the 'mit commit'-        -- was never run, we merely don't want to *say* "run 'mit undo' to undo" as feedback, because that sounds as-        -- if it would undo the last command run, namely the 'mit commit' that was aborted.-        canUndo = not (null undos) && committed,-        conflicts = [],-        syncs =-          case Seq1.fromSeq localCommits of-            Nothing -> []-            Just commits ->-              [ Sync-                  { commits,-                    result = pushResultToSyncResult pushResult,-                    source = branch,-                    target = "origin/" <> branch-                  }-              ]-      }+  remoteCommits <-+    if existRemoteCommits+      then gitCommitsBetween (Just head1) (fromJust maybeUpstreamHead)+      else pure Seq.empty +  putStanzas+    [ isSynchronizedStanza (Text.Builder.fromText branch) pushResult,+      Seq1.fromSeq remoteCommits <&> \commits ->+        syncStanza+          Sync+            { commits,+              result = SyncResult'Failure,+              source = upstream,+              target = branch+            },+      Seq1.fromSeq localCommits <&> \commits ->+        syncStanza+          Sync+            { commits,+              result = pushResultToSyncResult pushResult,+              source = branch,+              target = upstream+            },+      case pushResult of+        PushNotAttempted (ForkedHistory (List1.nonEmpty -> Just conflicts)) ->+          conflictsStanza+            ("These files will be in conflict when you run " <> Text.Builder.bold (Text.Builder.blue "mit sync") <> ":")+            conflicts+        _ -> Nothing,+      whatNextStanza (Text.Builder.fromText branch) pushResult,+      -- 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 undos) && committed then Just canUndoStanza else Nothing+    ]+ mitCommitMerge :: IO () mitCommitMerge = do   branch <- gitCurrentBranch@@ -244,33 +300,52 @@   head <- gitHead   state0 <- readMitState branch64 +  -- 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 state0.merging of-    Nothing -> gitl_ ["commit", "--all", "--no-edit"]+    Nothing -> git_ ["commit", "--all", "--no-edit"]     Just merging ->       let message = fold ["⅄ ", if merging == branch then "" else merging <> " → ", branch]-       in gitl_ ["commit", "--all", "--message", message]-  case listToMaybe [commit | Apply commit <- state0.undos] of-    Nothing -> mitSyncWith (Just [Reset head])-    Just stash ->-      gitApplyStash stash >>= \case+       in git_ ["commit", "--all", "--message", message]++  writeMitState branch64 state0 {merging = Nothing, ranCommitAt = Nothing}++  let stanza0 = do+        merging <- state0.merging+        guard (merging /= branch)+        synchronizedStanza (Text.Builder.fromText branch) (Text.Builder.fromText 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 state0.undos of+    Nothing -> mitSyncWith stanza0 (Just [Reset head])+    Just stash -> do+      conflicts <- gitApplyStash stash+      case List1.nonEmpty conflicts of         -- FIXME we just unstashed, now we're about to stash again :/-        [] -> mitSyncWith (Just [Reset head, Apply stash])-        conflicts -> do-          writeMitState branch64 state0 {merging = Nothing, ranCommitAt = Nothing}-          putSummary-            Summary-              { branch,-                canUndo = not (null state0.undos),-                conflicts,-                syncs = []-              }+        Nothing -> mitSyncWith stanza0 (Just [Reset head, Apply stash])+        Just conflicts1 ->+          putStanzas+            [ stanza0,+              conflictsStanza "These files are in conflict:" conflicts1,+              -- Fake like we didn't push due to merge conflicts just to print "resolve conflicts and commit"+              whatNextStanza (Text.Builder.fromText branch) (PushNotAttempted MergeConflicts),+              if null state0.undos then Nothing else Just canUndoStanza+            ]  data PushResult   = PushAttempted Bool   | PushNotAttempted PushNotAttemptedReason  data PushNotAttemptedReason-  = ForkedHistory -- local history has forked, need to sync+  = ForkedHistory [GitConflict] -- local history has forked, need to sync.+  | MergeConflicts -- local merge conflicts that need to be resolved right now   | NothingToPush -- no commits to push   | Offline -- fetch failed, so we seem offline   | UnseenCommits -- we just pulled remote commits; don't push in case there's something local to address@@ -279,7 +354,8 @@ pushResultToSyncResult = \case   PushAttempted False -> SyncResult'Failure   PushAttempted True -> SyncResult'Success-  PushNotAttempted ForkedHistory -> SyncResult'Failure+  PushNotAttempted (ForkedHistory _) -> SyncResult'Failure+  PushNotAttempted MergeConflicts -> SyncResult'Failure   PushNotAttempted NothingToPush -> SyncResult'Success -- doesnt matter, wont be shown   PushNotAttempted Offline -> SyncResult'Offline   PushNotAttempted UnseenCommits -> SyncResult'Pending@@ -301,15 +377,24 @@    maybeMergeStatus <- mitMerge' ("⅄ " <> target <> " → " <> branch) targetCommit +  let maybeMergeResult = (.result) <$> maybeMergeStatus++  let conflicts =+        case maybeMergeResult of+          Nothing -> []+          Just (MergeResult'MergeConflicts conflicts1) -> List1.toList conflicts1+          Just (MergeResult'StashConflicts conflicts1) -> List1.toList conflicts1+          Just MergeResult'Success -> []+   writeMitState     branch64     MitState       { head = (),         merging = do-          mergeStatus <- maybeMergeStatus-          case mergeStatus.result of-            MergeResult'MergeConflicts _ -> Just target-            MergeResult'StashConflicts _ -> Nothing,+          result <- maybeMergeResult+          if mergeResultCommitted result+            then Nothing+            else Just target,         ranCommitAt = Nothing,         undos =           case maybeMergeStatus of@@ -317,32 +402,44 @@             Just mergeStatus -> List1.toList mergeStatus.undos       } -  putSummary-    Summary-      { branch,-        canUndo = isJust maybeMergeStatus,-        conflicts =-          case maybeMergeStatus of-            Nothing -> []-            Just mergeStatus ->-              case mergeStatus.result of-                MergeResult'MergeConflicts conflicts -> List1.toList conflicts-                MergeResult'StashConflicts conflicts -> conflicts,-        syncs = do-          mergeStatus <- maybeToList maybeMergeStatus-          pure-            Sync-              { commits = mergeStatus.commits,-                result =-                  case mergeStatus.result of-                    MergeResult'MergeConflicts _ -> SyncResult'Failure-                    -- Even if we have conflicts from unstashing, we call this merge a success.-                    MergeResult'StashConflicts _ -> SyncResult'Success,-                source = target,-                target = branch-              }-      }+  let branchb = Text.Builder.fromText branch+  let targetb = Text.Builder.fromText target +  putStanzas+    [ case maybeMergeResult of+        Nothing -> synchronizedStanza branchb targetb+        Just result ->+          if mergeResultCommitted result+            then synchronizedStanza branchb targetb+            else notSynchronizedStanza branchb targetb ".",+      maybeMergeStatus <&> \mergeStatus ->+        syncStanza+          Sync+            { commits = mergeStatus.commits,+              result = if mergeResultCommitted mergeStatus.result then SyncResult'Success else SyncResult'Failure,+              source = target,+              target = branch+            },+      do+        result <- maybeMergeResult+        if mergeResultCommitted result+          then isSynchronizedStanza branchb (PushNotAttempted UnseenCommits)+          else Nothing,+      do+        conflicts1 <- List1.nonEmpty conflicts+        conflictsStanza "These files are in conflict:" conflicts1,+      do+        result <- maybeMergeResult+        whatNextStanza+          branchb+          ( case result of+              MergeResult'MergeConflicts _ -> PushNotAttempted MergeConflicts+              MergeResult'StashConflicts _ -> PushNotAttempted UnseenCommits+              MergeResult'Success -> PushNotAttempted UnseenCommits+          ),+      if isJust maybeMergeStatus then Just canUndoStanza else Nothing+    ]+ data MergeStatus = MergeStatus   { commits :: Seq1 GitCommitInfo,     result :: MergeResult,@@ -351,8 +448,16 @@  data MergeResult   = MergeResult'MergeConflicts (List1 GitConflict)-  | MergeResult'StashConflicts [GitConflict]+  | MergeResult'StashConflicts (List1 GitConflict)+  | MergeResult'Success +-- | Did this merge commit (possibly leaving behind a conflicting unstash)?+mergeResultCommitted :: MergeResult -> Bool+mergeResultCommitted = \case+  MergeResult'MergeConflicts _ -> False+  MergeResult'StashConflicts _ -> True+  MergeResult'Success -> True+ mitMerge' :: Text -> Text -> IO (Maybe MergeStatus) mitMerge' message target = do   head <- gitHead@@ -362,7 +467,7 @@       maybeStash <- gitStash       let undos = Reset head :| maybeToList (Apply <$> maybeStash)       result <--        gitl ["merge", "--ff", "--no-commit", target] >>= \case+        git ["merge", "--ff", "--no-commit", target] >>= \case           False -> do             conflicts <- gitConflicts             -- error: The following untracked working tree files would be overwritten by merge:@@ -386,9 +491,14 @@             -- Aborting             pure (MergeResult'MergeConflicts (List1.fromList conflicts))           True -> do-            whenM gitMergeInProgress (gitl_ ["commit", "--message", message])+            whenM gitMergeInProgress (git_ ["commit", "--message", message])             maybeConflicts <- for maybeStash gitApplyStash-            pure (MergeResult'StashConflicts (fromMaybe [] maybeConflicts))+            pure+              ( fromMaybe MergeResult'Success do+                  conflicts <- maybeConflicts+                  conflicts1 <- List1.nonEmpty conflicts+                  pure (MergeResult'StashConflicts conflicts1)+              )       pure (Just MergeStatus {commits, result, undos})  -- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream@@ -397,9 +507,9 @@   dieIfNotInGitDir   dieIfMergeInProgress   whenM gitExistUntrackedFiles dieIfBuggyGit-  mitSyncWith Nothing+  mitSyncWith Nothing Nothing --- | @mitSyncWith maybeUndos@+-- | @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.@@ -419,11 +529,11 @@ -- -- Instead, we want to undo to the point before running the 'mit merge' that caused the conflicts, which were later -- resolved by 'mit commit'.-mitSyncWith :: Maybe [Undo] -> IO ()-mitSyncWith maybeUndos = do+mitSyncWith :: Maybe Text.Builder -> Maybe [Undo] -> IO ()+mitSyncWith stanza0 maybeUndos = do   fetched <- gitFetch "origin"   branch <- gitCurrentBranch-  let branch64 = Text.encodeBase64 branch+  let upstream = "origin/" <> branch   maybeUpstreamHead <- gitRemoteBranchHead "origin" branch    maybeMergeStatus <-@@ -431,16 +541,23 @@       Nothing -> pure Nothing       Just upstreamHead -> mitMerge' ("⅄ " <> branch) upstreamHead +  let maybeMergeResult = (.result) <$> maybeMergeStatus++  let conflicts =+        case maybeMergeResult of+          Nothing -> []+          Just (MergeResult'MergeConflicts conflicts1) -> List1.toList conflicts1+          Just (MergeResult'StashConflicts conflicts1) -> List1.toList conflicts1+          Just MergeResult'Success -> []+   localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD"    pushResult <--    case (localCommits, (.result) <$> maybeMergeStatus, fetched) of+    case (localCommits, maybeMergeResult, fetched) of       (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush)-      -- "forked history" is ok - a bit different than history *already* having forked, in which case a push-      -- would just fail, whereas this is just us choosing not to push while in the middle of a merge due to a-      -- previous fork in the history-      (Seq.NonEmpty, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory)+      (Seq.NonEmpty, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted MergeConflicts)       (Seq.NonEmpty, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits)+      (Seq.NonEmpty, Just MergeResult'Success, _) -> pure (PushNotAttempted UnseenCommits)       (Seq.NonEmpty, Nothing, False) -> pure (PushNotAttempted Offline)       (Seq.NonEmpty, Nothing, True) -> PushAttempted <$> gitPush branch @@ -455,54 +572,43 @@           True -> []    writeMitState-    branch64+    (Text.encodeBase64 branch)     MitState       { head = (),         merging = do-          mergeStatus <- maybeMergeStatus-          case mergeStatus.result of-            MergeResult'MergeConflicts _ -> Just branch-            MergeResult'StashConflicts _ -> Nothing,+          result <- maybeMergeResult+          if mergeResultCommitted result+            then Nothing+            else Just branch,         ranCommitAt = Nothing,         undos       } -  putSummary-    Summary-      { branch,-        canUndo = not (null undos),-        conflicts =-          case maybeMergeStatus of-            Nothing -> []-            Just mergeStatus ->-              case mergeStatus.result of-                MergeResult'MergeConflicts conflicts -> List1.toList conflicts-                MergeResult'StashConflicts conflicts -> conflicts,-        syncs =-          catMaybes-            [ do-                mergeStatus <- maybeMergeStatus-                pure-                  Sync-                    { commits = mergeStatus.commits,-                      result =-                        case mergeStatus.result of-                          MergeResult'MergeConflicts _ -> SyncResult'Failure-                          MergeResult'StashConflicts _ -> SyncResult'Success,-                      source = "origin/" <> branch,-                      target = branch-                    },-              do-                commits <- Seq1.fromSeq localCommits-                pure-                  Sync-                    { commits,-                      result = pushResultToSyncResult pushResult,-                      source = branch,-                      target = "origin/" <> branch-                    }-            ]-      }+  putStanzas+    [ stanza0,+      isSynchronizedStanza (Text.Builder.fromText branch) pushResult,+      maybeMergeStatus <&> \mergeStatus ->+        syncStanza+          Sync+            { commits = mergeStatus.commits,+              result = if mergeResultCommitted mergeStatus.result then SyncResult'Success else SyncResult'Failure,+              source = upstream,+              target = branch+            },+      Seq1.fromSeq localCommits <&> \commits ->+        syncStanza+          Sync+            { commits,+              result = pushResultToSyncResult pushResult,+              source = branch,+              target = upstream+            },+      do+        conflicts1 <- List1.nonEmpty conflicts+        conflictsStanza "These files are in conflict:" conflicts1,+      whatNextStanza (Text.Builder.fromText branch) pushResult,+      if not (null undos) then Just canUndoStanza else Nothing+    ]  -- FIXME output what we just undid mitUndo :: IO ()@@ -513,7 +619,7 @@   state0 <- readMitState branch64   case List1.nonEmpty state0.undos of     Nothing -> exitFailure-    Just undos1 -> applyUndos undos1+    Just undos1 -> for_ undos1 applyUndo   when (undosContainRevert state0.undos) mitSync   where     undosContainRevert :: [Undo] -> Bool@@ -522,13 +628,6 @@       Revert _ : _ -> True       _ : undos -> undosContainRevert undos -data Summary = Summary-  { branch :: Text,-    canUndo :: Bool,-    conflicts :: [GitConflict],-    syncs :: [Sync]-  }- data Sync = Sync   { commits :: Seq1 GitCommitInfo,     result :: SyncResult,@@ -541,44 +640,142 @@   | SyncResult'Offline   | SyncResult'Pending   | SyncResult'Success+  deriving stock (Eq) --- FIXME show some graph of where local/remote is at-putSummary :: Summary -> IO ()-putSummary summary =-  let output = concatMap syncLines summary.syncs ++ conflictsLines ++ undoLines-   in if null output then pure () else putLines (map (Text.Lazy.toStrict . Text.Builder.toLazyText) ("" : output))+canUndoStanza :: Text.Builder+canUndoStanza =+  "  Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change."++conflictsStanza :: Text.Builder -> List1 GitConflict -> Maybe Text.Builder+conflictsStanza prefix conflicts =+  Just $+    "  "+      <> prefix+      <> Builder.newline+      <> Builder.vcat ((\conflict -> "    " <> Text.Builder.red (showGitConflict conflict)) <$> conflicts)++isSynchronizedStanza :: Text.Builder -> PushResult -> Maybe Text.Builder+isSynchronizedStanza branch = \case+  PushAttempted False ->+    notSynchronizedStanza branch upstream (" because " <> Text.Builder.bold "git push" <> " failed.")+  PushAttempted True -> synchronizedStanza branch upstream+  PushNotAttempted MergeConflicts ->+    notSynchronizedStanza branch upstream " because you have local conflicts to resolve."+  PushNotAttempted (ForkedHistory _) -> notSynchronizedStanza branch upstream "; their commit histories have diverged."+  PushNotAttempted NothingToPush -> synchronizedStanza branch upstream+  PushNotAttempted Offline -> notSynchronizedStanza branch upstream " because you appear to be offline."+  PushNotAttempted UnseenCommits -> notSynchronizedStanza branch upstream "."   where-    conflictsLines :: [Text.Builder]-    conflictsLines =-      if null summary.conflicts-        then []+    upstream = "origin/" <> branch++notSynchronizedStanza :: Text.Builder -> Text.Builder -> Text.Builder -> Maybe Text.Builder+notSynchronizedStanza branch other suffix =+  Just+    ( "  "+        <> Text.Builder.red+          ( Text.Builder.italic branch+              <> " is not synchronized with "+              <> Text.Builder.italic other+              <> suffix+          )+    )++whatNextStanza :: Text.Builder -> PushResult -> Maybe Text.Builder+whatNextStanza branch = \case+  PushAttempted False ->+    Just $+      "  Run "+        <> sync+        <> " to synchronize "+        <> Text.Builder.italic branch+        <> " with "+        <> Text.Builder.italic upstream+        <> "."+  PushAttempted True -> Nothing+  PushNotAttempted (ForkedHistory conflicts) ->+    Just $+      if null conflicts+        then+          "  Run "+            <> sync+            <> ", examine the repository, then run "+            <> sync+            <> " again to synchronize "+            <> Text.Builder.italic branch+            <> " with "+            <> Text.Builder.italic upstream+            <> "."         else-          "  The following files have conflicts." :-          map (("    " <>) . Text.Builder.red . showGitConflict) summary.conflicts ++ [""]-    syncLines :: Sync -> [Text.Builder]-    syncLines sync =-      colorize-        ( Text.Builder.italic-            ("  " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)-        ) :-      map (("  " <>) . prettyGitCommitInfo) (toList @Seq commits')-        ++ (if more then ["  ...", ""] else [""])-      where-        colorize :: Text.Builder -> Text.Builder-        colorize =-          case sync.result of-            SyncResult'Failure -> Text.Builder.red-            SyncResult'Offline -> Text.Builder.brightBlack-            SyncResult'Pending -> Text.Builder.yellow-            SyncResult'Success -> Text.Builder.green-        (commits', more) =-          case Seq1.length sync.commits > 10 of-            False -> (Seq1.toSeq sync.commits, False)-            True -> (Seq1.dropEnd 1 sync.commits, True)-    undoLines :: [Text.Builder]-    undoLines =-      if summary.canUndo-        then ["  Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change.", ""]-        else []+          "  Run "+            <> sync+            <> ", resolve the conflicts, then run "+            <> commit+            <> " to synchronize "+            <> Text.Builder.italic branch+            <> " with "+            <> Text.Builder.italic upstream+            <> "."+  PushNotAttempted MergeConflicts ->+    Just ("  Resolve the merge conflicts, then run " <> commit <> ".")+  PushNotAttempted NothingToPush -> Nothing+  PushNotAttempted Offline ->+    Just $+      "  When you come online, run "+        <> sync+        <> " to synchronize "+        <> Text.Builder.italic branch+        <> " with "+        <> Text.Builder.italic upstream+        <> "."+  PushNotAttempted UnseenCommits ->+    Just $+      "  Examine the repository, then run "+        <> sync+        <> " to synchronize "+        <> Text.Builder.italic branch+        <> " with "+        <> Text.Builder.italic upstream+        <> "."+  where+    commit = Text.Builder.bold (Text.Builder.blue "mit commit")+    sync = Text.Builder.bold (Text.Builder.blue "mit sync")+    upstream = "origin/" <> branch --- Undo file utils+syncStanza :: Sync -> Text.Builder+syncStanza sync =+  Text.Builder.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 =+      case sync.result of+        SyncResult'Failure -> Text.Builder.red+        SyncResult'Offline -> Text.Builder.brightBlack+        SyncResult'Pending -> Text.Builder.yellow+        SyncResult'Success -> Text.Builder.green+    (commits', more) =+      case Seq1.length sync.commits > 10 of+        False -> (Seq1.toSeq sync.commits, False)+        True -> (Seq1.dropEnd 1 sync.commits, True)++synchronizedStanza :: Text.Builder -> Text.Builder -> Maybe Text.Builder+synchronizedStanza branch other =+  Just+    ( "  "+        <> Text.Builder.green+          (Text.Builder.italic branch <> " is synchronized with " <> Text.Builder.italic other <> ".")+    )++renderStanzas :: [Maybe Text.Builder] -> Maybe Text.Builder+renderStanzas stanzas =+  case catMaybes stanzas of+    [] -> Nothing+    stanzas' -> Just (mconcat (List.intersperse (Builder.newline <> Builder.newline) stanzas'))++putStanzas :: [Maybe Text.Builder] -> IO ()+putStanzas stanzas =+  whenJust (renderStanzas stanzas) \s ->+    Text.putStr (Builder.build (Builder.newline <> s <> Builder.newline <> Builder.newline))
+ src/Mit/Builder.hs view
@@ -0,0 +1,58 @@+module Mit.Builder+  ( empty,+    build,+    hcat,+    newline,+    put,+    putln,+    space,+    squoted,+    vcat,+  )+where++import qualified Data.List as List+import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy 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/Config.hs view
@@ -0,0 +1,17 @@+module Mit.Config+  ( verbose,+  )+where++import Mit.Prelude+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)++verbose :: Int+verbose =+  unsafePerformIO do+    lookupEnv "MIT_VERBOSE" <&> \case+      Just "1" -> 1+      Just "2" -> 2+      _ -> 0+{-# NOINLINE verbose #-}
src/Mit/Git.hs view
@@ -3,13 +3,13 @@ import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text as Text-import qualified Data.Text.ANSI as Text import qualified Data.Text.Builder.ANSI as Text.Builder import qualified Data.Text.IO as Text import qualified Data.Text.Lazy.Builder as Text (Builder) import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Ki-import Mit.Globals (debug)+import qualified Mit.Builder as Builder+import Mit.Config (verbose) import Mit.Prelude import Mit.Process import System.Directory (doesFileExist)@@ -51,11 +51,11 @@ 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?     ] @@ -115,7 +115,7 @@ gitApplyStash :: Text -> IO [GitConflict] gitApplyStash stash = do   conflicts <--    git ["stash", "apply", stash] >>= \case+    git ["stash", "apply", "--quiet", stash] >>= \case       False -> gitConflicts       True -> pure []   gitUnstageChanges@@ -124,7 +124,7 @@ -- | Create a branch. gitBranch :: Text -> IO () gitBranch branch =-  gitl_ ["branch", "--no-track", branch]+  git_ ["branch", "--no-track", branch]  -- | Does the given local branch (refs/heads/...) exist? gitBranchExists :: Text -> IO Bool@@ -151,9 +151,9 @@   queryTerminal 0 >>= \case     False -> do       message <- lookupEnv "MIT_COMMIT_MESSAGE"-      gitl ["commit", "--all", "--message", maybe "" Text.pack message]+      git ["commit", "--all", "--message", maybe "" Text.pack message]     True ->-      gitl2 ["commit", "--patch", "--quiet"] <&> \case+      git2 ["commit", "--patch", "--quiet"] <&> \case         ExitFailure _ -> False         ExitSuccess -> True @@ -189,6 +189,20 @@ gitConflicts =   mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"] +-- | Get the conflicts with the given commitish.+--+-- Precondition: there is no merge in progress.+gitConflictsWith :: Text -> IO [GitConflict]+gitConflictsWith commit = do+  maybeStash <- gitStash+  conflicts <-+    git ["merge", "--no-commit", "--no-ff", commit] >>= \case+      False -> gitConflicts+      True -> pure []+  git_ ["merge", "--abort"]+  whenJust maybeStash \stash -> git_ ["stash", "apply", "--quiet", stash]+  pure conflicts+ gitCreateStash :: IO Text gitCreateStash = do   git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed@@ -227,7 +241,7 @@  gitFetch :: Text -> IO Bool gitFetch remote =-  gitl ["fetch", remote]+  git ["fetch", remote]  gitFetch_ :: Text -> IO () gitFetch_ =@@ -248,7 +262,7 @@  gitPush :: Text -> IO Bool gitPush branch =-  gitl ["push", "--set-upstream", "origin", branch <> ":" <> branch]+  git ["push", "--set-upstream", "origin", "--quiet", branch <> ":" <> branch]  -- | Does the given remote branch (refs/remotes/...) exist? gitRemoteBranchExists :: Text -> Text -> IO Bool@@ -283,7 +297,7 @@  gitUnstageChanges :: IO () gitUnstageChanges = do-  git_ ["reset", "--mixed"]+  git_ ["reset", "--mixed", "--quiet"]   untrackedFiles <- gitListUntrackedFiles   unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles)) @@ -291,7 +305,7 @@ gitVersion = do   v0 <- git ["--version"]   fromMaybe (throwIO (userError ("Could not parse git version from: " <> Text.unpack v0))) do-    ["git", "version", v1] <- Just (Text.words v0)+    "git" : "version" : v1 : _ <- Just (Text.words v0)     [sx, sy, sz] <- Just (Text.split (== '.') v1)     x <- readMaybe (Text.unpack sx)     y <- readMaybe (Text.unpack sy)@@ -328,15 +342,7 @@   pure (url, Text.takeWhileEnd (/= '/') url')  git :: ProcessOutput a => [Text] -> IO a-git =-  git' False--gitl :: ProcessOutput a => [Text] -> IO a-gitl =-  git' True--git' :: ProcessOutput a => Bool -> [Text] -> IO a-git' effectful args = do+git args = do   let spec :: CreateProcess       spec =         CreateProcess@@ -357,7 +363,6 @@             detach_console = False,             use_process_jobs = False           }-  when effectful (logProcess "git" args)   bracket (createProcess spec) cleanup \(_maybeStdin, maybeStdout, maybeStderr, processHandle) ->     Ki.scoped \scope -> do       stdoutThread <- Ki.fork scope (drainTextHandle (fromJust maybeStdout))@@ -391,14 +396,9 @@ git_ =   git -gitl_ :: [Text] -> IO ()-gitl_ =-  gitl- -- Yucky interactive/inherity variant (so 'git commit' can open an editor).-gitl2 :: [Text] -> IO ExitCode-gitl2 args = do-  logProcess "git" args+git2 :: [Text] -> IO ExitCode+git2 args = do   (Nothing, Nothing, Just stderrHandle, processHandle) <-     createProcess       CreateProcess@@ -429,18 +429,25 @@  debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO () debugPrintGit args stdoutLines stderrLines exitCode =-  when debug do-    putLines do-      let output :: [Text]-          output =-            map (Text.brightBlack . ("    " <>)) (toList @Seq (stdoutLines <> stderrLines))-      Text.bold (Text.brightBlack (Text.unwords (marker <> " git" : map quoteText args))) : output+  case verbose of+    1 -> Builder.putln (Text.Builder.brightBlack v1)+    2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2))+    _ -> pure ()   where-    marker :: Text+    v1 = Text.Builder.bold (marker <> " 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 _ -> "✗"-        ExitSuccess -> "✓"+        ExitFailure _ -> Text.Builder.singleton '✗'+        ExitSuccess -> Text.Builder.singleton '✓'  drainTextHandle :: Handle -> IO (Seq Text) drainTextHandle handle = do
− src/Mit/Globals.hs 
@@ -1,10 +0,0 @@-module Mit.Globals where--import Mit.Prelude-import System.Environment (lookupEnv)-import System.IO.Unsafe (unsafePerformIO)--debug :: Bool-debug =-  isJust (unsafePerformIO (lookupEnv "debug"))-{-# NOINLINE debug #-}
src/Mit/Process.hs view
@@ -4,22 +4,7 @@  import qualified Data.Sequence as Seq import Mit.Prelude-import qualified Data.Text as Text-import qualified Data.Text.IO as Text-import qualified Data.Text.Lazy as Text.Lazy-import qualified Data.List as List-import qualified Data.Text.Builder.ANSI as Text.Builder-import qualified Data.Text.Lazy.Builder as Text.Builder import System.Exit (ExitCode (..), exitWith)--logProcess :: Text -> [Text] -> IO ()-logProcess s0 ss =-  Text.putStrLn (Text.Lazy.toStrict (Text.Builder.toLazyText line))-  where-    line = "» " <> Text.Builder.bold (Text.Builder.fromText s0 <> space <> formatArgs ss)-    formatArgs = mconcat . List.intersperse space . map formatArg-    formatArg s = Text.Builder.fromText (if Text.elem ' ' s then s else s)-    space = Text.Builder.singleton ' '  class ProcessOutput a where   fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO a
src/Mit/Seq.hs view
@@ -1,5 +1,6 @@ module Mit.Seq where +import qualified Data.Foldable as Foldable import Data.Sequence  pattern NonEmpty :: Seq a@@ -9,3 +10,7 @@  pattern Singleton :: Seq a pattern Singleton <- _ :<| Empty++toList :: Seq a -> [a]+toList =+  Foldable.toList
src/Mit/Undo.hs view
@@ -33,13 +33,16 @@           error (show text)         ] -applyUndos :: List1 Undo -> IO ()-applyUndos =-  traverse_ \case-    Apply commit -> do-      gitl_ ["stash", "apply", commit]-      gitUnstageChanges-    Reset commit -> do-      gitl_ ["clean", "-d", "--force"]-      gitl ["reset", "--hard", commit]-    Revert commit -> gitl_ ["revert", commit]+applyUndo :: Undo -> IO ()+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]++undosStash :: [Undo] -> Maybe Text+undosStash undos =+  listToMaybe [commit | Apply commit <- undos]