mit-3qvpPyAi6mH 10 → 11

raw patch · 9 files changed

+271/−581 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• mit-3qvpPyAi6mH.cabal +2/−2
• src/Mit.hs +141/−179
• src/Mit/Directory.hs +1/−1
• src/Mit/Env.hs +1/−2
• src/Mit/Git.hs +82/−76
• src/Mit/GitCommand.hs +0/−263
• src/Mit/Monad.hs +37/−51
• src/Mit/State.hs +6/−6
• src/Mit/Undo.hs +1/−1

@@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX-version: 10+version: 11  description:   A git wrapper with a streamlined UX.@@ -33,6 +33,7 @@     BlockArguments     DataKinds     DefaultSignatures+    DeriveAnyClass     DeriveFunctor     DerivingStrategies     DuplicateRecordFields@@ -90,7 +91,6 @@     Mit.Directory     Mit.Env     Mit.Git-    Mit.GitCommand     Mit.Monad     Mit.Prelude     Mit.Process

@@ -3,6 +3,7 @@   ) where +import Control.Applicative (many) import Data.List.NonEmpty qualified as List1 import Data.Ord (clamp) import Data.Sequence qualified as Seq@@ -14,7 +15,6 @@ import Mit.Directory import Mit.Env import Mit.Git-import Mit.GitCommand qualified as Git import Mit.Monad import Mit.Prelude import Mit.Seq1 qualified as Seq1@@ -45,24 +45,20 @@ main = do   (verbosity, command) <- Opt.customExecParser parserPrefs parserInfo -  let action :: forall x. Mit () x [Stanza]+  let action :: Mit Env [Stanza]       action = do-        withEnv (\() -> Env {gitdir = "", verbosity}) gitRevParseAbsoluteGitDir >>= \case-          Nothing -> pure [Just (Text.red "The current directory doesn't contain a git repository.")]-          Just gitdir -> do-            withEnv-              (\() -> Env {gitdir, verbosity})-              ( do-                  label \return -> do-                    case command of-                      MitCommand'Branch branch -> mitBranch return branch $> []-                      MitCommand'Commit -> mitCommit @x return $> []-                      MitCommand'Merge branch -> mitMerge @x return branch $> []-                      MitCommand'Sync -> mitSync @x return $> []-                      MitCommand'Undo -> mitUndo @x return $> []-              )+        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 () action >>= \case+  runMit Env {verbosity} action >>= \case     [] -> pure ()     errs -> do       putStanzas errs@@ -90,9 +86,7 @@     parser :: Opt.Parser (Int, MitCommand)     parser =       (,)-        <$> ( clamp (0, 2)-                <$> Opt.option Opt.auto (Opt.help "Verbosity" <> Opt.metavar "«n»" <> Opt.short 'v' <> Opt.value 0)-            )+        <$> (clamp (0, 2) . length <$> many (Opt.flag' () (Opt.help "Verbose (-v or -vv)" <> Opt.short 'v')))         <*> (Opt.hsubparser . fold)           [ Opt.command "branch" $               Opt.info@@ -123,7 +117,7 @@   | MitCommand'Sync   | MitCommand'Undo -dieIfBuggyGit :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+dieIfBuggyGit :: Goto Env [Stanza] -> Mit Env () dieIfBuggyGit return = do   version <- gitVersion return   let validate (ver, err) = if version < ver then ((ver, err) :) else id@@ -160,17 +154,14 @@         )       ] -dieIfMergeInProgress :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()+dieIfMergeInProgress :: Goto Env [Stanza] -> Mit Env () dieIfMergeInProgress return =   whenM gitMergeInProgress (return [Just (Text.red (Text.bold "git merge" <> " in progress."))]) -mitBranch ::-  Goto Env x [Stanza] ->-  Text ->-  Mit Env (X x [Stanza]) ()+mitBranch :: Goto Env [Stanza] -> Text -> Mit Env () mitBranch return branch = do   worktreeDir <- do-    rootdir <- gitRevParseShowToplevel+    rootdir <- git ["rev-parse", "--show-toplevel"]     pure (Text.dropWhileEnd (/= '/') rootdir <> branch)    gitBranchWorktreeDir branch >>= \case@@ -179,14 +170,14 @@         return [Just (Text.red ("Directory " <> Text.bold (Text.Builder.fromText worktreeDir) <> " already exists."))]       git_ ["worktree", "add", "--detach", worktreeDir]       cd worktreeDir do-        whenNotM (Git.git (Git.Switch branch)) do-          gitBranch branch-          Git.git_ (Git.Switch branch)+        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.git_ (Git.Reset Git.Hard Git.FlagQuiet upstream)-            Git.git_ (Git.BranchSetUpstreamTo upstream)+            git_ ["reset", "--hard", "--quiet", upstream]+            git_ ["branch", "--set-upstream-to", upstream]     Just directory ->       when (directory /= worktreeDir) do         return@@ -202,9 +193,9 @@               )           ] -mitCommit :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+mitCommit :: Goto Env [Stanza] -> Mit Env () mitCommit return = do-  whenM gitExistUntrackedFiles (dieIfBuggyGit @x return)+  whenM gitExistUntrackedFiles (dieIfBuggyGit return)    gitMergeInProgress >>= \case     False ->@@ -213,10 +204,10 @@         NoDifferences -> return [Just (Text.red "There's nothing to commit.")]     True -> mitCommitMerge -mitCommit_ :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()+mitCommit_ :: Goto Env [Stanza] -> Mit Env () mitCommit_ return = do   context <- getContext-  let upstream = "origin/" <> context.branch+  let upstream = contextUpstream context    existRemoteCommits <- contextExistRemoteCommits context   existLocalCommits <- contextExistLocalCommits context@@ -230,6 +221,16 @@   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@@ -242,13 +243,13 @@                   case context.snapshot of                     Nothing -> []                     Just snapshot -> undoToSnapshot snapshot-                (True, False) -> push.undo+                (True, False) -> undoPush                 (True, True) ->-                  if null push.undo+                  if null undoPush                     then []                     else case context.snapshot of-                      Nothing -> push.undo-                      Just snapshot -> push.undo ++ [Apply (fromJust snapshot.stash)]+                      Nothing -> undoPush+                      Just snapshot -> undoPush ++ [Apply (fromJust snapshot.stash)]           }    writeMitState context.branch state@@ -265,18 +266,17 @@    io do     putStanzas-      [ isSynchronizedStanza2 context.branch push.what,+      [ isSynchronizedStanza context.branch push,         do           commits <- Seq1.fromSeq remoteCommits           syncStanza Sync {commits, success = False, source = upstream, target = context.branch},         do-          commits <- Seq1.fromSeq push.commits+          commits <- pushCommits push           syncStanza Sync {commits, success = pushPushed push, source = context.branch, target = upstream},-        case push.what of-          NothingToPush2 -> Nothing-          Pushed -> Nothing-          PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream-          PushWouldBeRejected ->+        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 ->@@ -298,7 +298,8 @@                         <> branchb upstream                         <> "."                   ]-          TriedToPush -> runSyncStanza "Run" context.branch 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.         --@@ -308,9 +309,10 @@         if not (null state.undos) && committed then canUndoStanza else Nothing       ] -mitCommitMerge :: Mit Env x ()+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`,@@ -347,37 +349,31 @@             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 context.branch (PushNotAttempted MergeConflicts),+                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               ] --- FIXME delete-data PushResult-  = PushAttempted Bool-  | PushNotAttempted PushNotAttemptedReason--data PushNotAttemptedReason-  = ForkedHistory [GitConflict] -- local history has forked, need to sync.-  | MergeConflicts -- local merge conflicts that need to be resolved right now-  | NothingToPush -- no commits to push-  | Offline -- fetch failed, so we seem offline-  | UnseenCommits -- we just pulled remote commits; don't push in case there's something local to address--mitMerge :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Text -> Mit Env xx ()+mitMerge :: Goto Env [Stanza] -> Text -> Mit Env () mitMerge return target = do   dieIfMergeInProgress return-  whenM gitExistUntrackedFiles (dieIfBuggyGit @x return)+  whenM gitExistUntrackedFiles (dieIfBuggyGit return)    context <- getContext-  let upstream = "origin/" <> context.branch+  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 @x return context target+    else mitMergeWith return context target -mitMergeWith :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Context -> Text -> Mit Env xx ()+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 <-@@ -387,7 +383,7 @@             & onNothingM (return [Just (Text.red "No such branch.")])         ) -  let upstream = "origin/" <> context.branch+  let upstream = contextUpstream context    existRemoteCommits <- contextExistRemoteCommits context   existLocalCommits <- contextExistLocalCommits context@@ -399,7 +395,7 @@       ]    whenJust (contextStash context) \_stash ->-    Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD")+    gitDeleteChanges    merge <- performMerge ("⅄ " <> target <> " → " <> context.branch) targetCommit @@ -453,7 +449,7 @@                 source = target,                 target = context.branch               },-        isSynchronizedStanza2 context.branch push.what,+        isSynchronizedStanza context.branch push,         do           commits <- Seq1.fromSeq remoteCommits           syncStanza Sync {commits, success = False, source = upstream, target = context.branch},@@ -462,12 +458,11 @@           conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts           conflictsStanza "These files are in conflict:" conflicts1,         -- TODO audit this-        case push.what of-          NothingToPush2 -> Nothing-          Pushed -> Nothing-          PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream+        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!-          PushWouldBeRejected ->+          DidntPush (PushWouldBeRejected _) ->             case List1.nonEmpty conflictsOnSync of               Nothing -> runSyncStanza "Run" context.branch upstream               Just conflictsOnSync1 ->@@ -489,15 +484,16 @@                         <> branchb upstream                         <> "."                   ]-          TriedToPush -> runSyncStanza "Run" context.branch 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 :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+mitSync :: Goto Env [Stanza] -> Mit Env () mitSync return = do   dieIfMergeInProgress return-  whenM gitExistUntrackedFiles (dieIfBuggyGit @x return)+  whenM gitExistUntrackedFiles (dieIfBuggyGit return)   mitSyncWith Nothing Nothing  -- | @mitSyncWith _ maybeUndos@@@ -520,13 +516,13 @@ -- -- Instead, we want to undo to the point before running the 'mit merge' that caused the conflicts, which were later -- resolved by 'mit commit'.-mitSyncWith :: Stanza -> Maybe [Undo] -> Mit Env x ()+mitSyncWith :: Stanza -> Maybe [Undo] -> Mit Env () mitSyncWith stanza0 maybeUndos = do   context <- getContext-  let upstream = "origin/" <> context.branch+  let upstream = contextUpstream context    whenJust (contextStash context) \_stash ->-    Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD")+    gitDeleteChanges    merge <-     case context.upstreamHead of@@ -570,7 +566,7 @@   io do     putStanzas       [ stanza0,-        isSynchronizedStanza2 context.branch push.what,+        isSynchronizedStanza context.branch push,         do           commits1 <- Seq1.fromSeq merge.commits           syncStanza@@ -581,7 +577,7 @@                 target = context.branch               },         do-          commits <- Seq1.fromSeq push.commits+          commits <- pushCommits push           syncStanza             Sync               { commits,@@ -592,11 +588,10 @@         do           conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts           conflictsStanza "These files are in conflict:" conflicts1,-        case push.what of-          NothingToPush2 -> Nothing-          Pushed -> Nothing-          PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream-          PushWouldBeRejected ->+        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")@@ -605,18 +600,19 @@                 <> " with "                 <> branchb upstream                 <> "."-          TriedToPush -> runSyncStanza "Run" context.branch 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 :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+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 @x return)+  when (undosContainRevert context.state.undos) (mitSync return)   where     undosContainRevert :: [Undo] -> Bool     undosContainRevert = \case@@ -644,13 +640,13 @@       <> Builder.newline       <> Builder.vcat ((\conflict -> "    " <> Text.red (showGitConflict conflict)) <$> conflicts) -isSynchronizedStanza2 :: Text -> GitPushWhat -> Stanza-isSynchronizedStanza2 branch = \case-  NothingToPush2 -> synchronizedStanza branch upstream-  Pushed -> synchronizedStanza branch upstream-  PushWouldntReachRemote -> notSynchronizedStanza branch upstream " because you appear to be offline."-  PushWouldBeRejected -> notSynchronizedStanza branch upstream "; their histories have diverged."-  TriedToPush -> notSynchronizedStanza branch upstream (" because " <> Text.bold "git push" <> " failed.")+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 @@ -692,44 +688,6 @@ synchronizedStanza branch other =   Just ("  " <> Text.green (branchb branch <> " is synchronized with " <> branchb other <> ".")) --- FIXME remove-whatNextStanza :: Text -> PushResult -> Stanza-whatNextStanza branch = \case-  PushAttempted False -> runSyncStanza "Run" branch upstream-  PushAttempted True -> Nothing-  PushNotAttempted (ForkedHistory conflicts) ->-    Just $-      if null conflicts-        then-          "  Run "-            <> sync-            <> ", examine the repository, then run "-            <> sync-            <> " again to synchronize "-            <> branchb branch-            <> " with "-            <> branchb upstream-            <> "."-        else-          "  Run "-            <> sync-            <> ", resolve the conflicts, then run "-            <> commit-            <> " to synchronize "-            <> branchb branch-            <> " with "-            <> branchb upstream-            <> "."-  PushNotAttempted MergeConflicts ->-    Just ("  Resolve the merge conflicts, then run " <> commit <> ".")-  PushNotAttempted NothingToPush -> Nothing-  PushNotAttempted Offline -> runSyncStanza "When you come online, run" branch upstream-  PushNotAttempted UnseenCommits -> runSyncStanza "Examine the repository, then run" branch upstream-  where-    commit = Text.bold (Text.blue "mit commit")-    sync = Text.bold (Text.blue "mit sync")-    upstream = "origin/" <> branch- branchb :: Text -> Text.Builder branchb =   Text.italic . Text.Builder.fromText@@ -744,16 +702,16 @@     upstreamHead :: Maybe Text   } -getContext :: Mit Env x Context+getContext :: Mit Env Context getContext = do   gitFetch_ "origin"-  branch <- Git.git Git.BranchShowCurrent+  branch <- git ["branch", "--show-current"]   upstreamHead <- gitRemoteBranchHead "origin" branch   state <- readMitState branch   snapshot <- performSnapshot   pure Context {branch, snapshot, state, upstreamHead} -contextExistLocalCommits :: Context -> Mit Env x Bool+contextExistLocalCommits :: Context -> Mit Env Bool contextExistLocalCommits context =   case context.upstreamHead of     Nothing -> pure True@@ -762,7 +720,7 @@         Nothing -> pure False         Just snapshot -> gitExistCommitsBetween upstreamHead snapshot.head -contextExistRemoteCommits :: Context -> Mit Env x Bool+contextExistRemoteCommits :: Context -> Mit Env Bool contextExistRemoteCommits context =   case context.upstreamHead of     Nothing -> pure False@@ -776,6 +734,10 @@   snapshot <- context.snapshot   snapshot.stash +contextUpstream :: Context -> Text+contextUpstream context =+  "origin/" <> context.branch+ ------------------------------------------------------------------------------------------------------------------------ -- Git merge @@ -794,7 +756,7 @@ -- conflicts. -- -- Precondition: the working directory is clean. TODO take unused GitStash as argument?-performMerge :: Text -> Text -> Mit Env x GitMerge+performMerge :: Text -> Text -> Mit Env GitMerge performMerge message commitish = do   head <- gitHead   commits <- gitCommitsBetween (Just head) commitish@@ -813,57 +775,57 @@ ------------------------------------------------------------------------------------------------------------------------ -- Git push -data GitPush = GitPush-  { commits :: Seq GitCommitInfo,-    undo :: [Undo],-    what :: GitPushWhat-  }+-- | The result of (considering a) git push.+data GitPush+  = -- | We didn't push anthing.+    DidntPush DidntPushReason+  | -- | We successfully pushed commits.+    Pushed (Seq1 GitCommitInfo) -data GitPushWhat-  = NothingToPush2-  | Pushed-  | PushWouldntReachRemote-  | PushWouldBeRejected-  | TriedToPush+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 push =-  case push.what of-    NothingToPush2 -> False-    Pushed -> True-    PushWouldntReachRemote -> False-    PushWouldBeRejected -> False-    TriedToPush -> False+pushPushed = \case+  DidntPush _ -> False+  Pushed _ -> True  -- TODO get context-performPush :: Text -> Mit Env x GitPush+performPush :: Text -> Mit Env GitPush performPush branch = do   fetched <- gitFetch "origin"   head <- gitHead   upstreamHead <- gitRemoteBranchHead "origin" branch   commits <- gitCommitsBetween upstreamHead head -  if Seq.null commits-    then pure GitPush {commits, undo = [], what = NothingToPush2}-    else do+  case Seq1.fromSeq commits of+    Nothing -> pure (DidntPush NothingToPush)+    Just commits1 -> do       existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head) upstreamHead       if existRemoteCommits-        then pure GitPush {commits, undo = [], what = PushWouldBeRejected}+        then pure (DidntPush (PushWouldBeRejected commits1))         else           if fetched-            then-              gitPush branch >>= \case-                False -> pure GitPush {commits, undo = [], what = TriedToPush}-                True -> do-                  undo <--                    if Seq.length commits == 1-                      then-                        gitIsMergeCommit head <&> \case-                          False -> [Revert head]-                          True -> []-                      else pure []-                  pure GitPush {commits, undo, what = Pushed}-            else pure GitPush {commits, undo = [], what = PushWouldntReachRemote}+            then do+              gitPush branch <&> \case+                False -> DidntPush (TriedToPush commits1)+                True -> Pushed commits1+            else pure (DidntPush (PushWouldntReachRemote commits1))  ------------------------------------------------------------------------------------------------------------------------ -- Git snapshot@@ -873,7 +835,7 @@     stash :: Maybe Text   } -performSnapshot :: Mit Env x (Maybe GitSnapshot)+performSnapshot :: Mit Env (Maybe GitSnapshot) performSnapshot = do   gitMaybeHead >>= \case     Nothing -> pure Nothing

@@ -9,7 +9,7 @@ import Mit.Prelude import System.Directory qualified as Directory -cd :: Text -> Mit r (X x a) a -> Mit r x a+cd :: Text -> Mit r a -> Mit r a cd dir =   with_ (Directory.withCurrentDirectory (Text.unpack dir)) 

@@ -6,6 +6,5 @@ import Mit.Prelude  data Env = Env-  { gitdir :: Text,-    verbosity :: Int+  { verbosity :: Int   }

@@ -1,7 +1,7 @@ -- | High-level git operations module Mit.Git   ( DiffResult (..),-    GitCommitInfo,+    GitCommitInfo (..),     prettyGitCommitInfo,     GitConflict,     showGitConflict,@@ -10,7 +10,6 @@     git,     git_,     gitApplyStash,-    gitBranch,     gitBranchHead,     gitBranchWorktreeDir,     gitCommit,@@ -18,6 +17,7 @@     gitConflicts,     gitConflictsWith,     gitCreateStash,+    gitDeleteChanges,     gitDiff,     gitExistCommitsBetween,     gitExistUntrackedFiles,@@ -31,7 +31,6 @@     gitRemoteBranchExists,     gitRemoteBranchHead,     gitRevParseAbsoluteGitDir,-    gitRevParseShowToplevel,     gitUnstageChanges,     gitVersion,     -- unused, but useful? not sure@@ -49,10 +48,11 @@ 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 GHC.Clock (getMonotonicTime) import Ki qualified import Mit.Builder qualified as Builder import Mit.Env (Env (..))-import Mit.GitCommand qualified as Git import Mit.Monad import Mit.Prelude import Mit.Process@@ -176,37 +176,31 @@   Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z)  -- | Apply stash, return conflicts.-gitApplyStash :: Text -> Mit Env x [GitConflict]+gitApplyStash :: Text -> Mit Env [GitConflict] gitApplyStash stash = do   conflicts <--    Git.git (Git.StashApply Git.FlagQuiet stash) >>= \case+    git ["stash", "apply", "--quiet", stash] >>= \case       False -> gitConflicts       True -> pure []   gitUnstageChanges   pure conflicts --- | Create a branch.--- FIXME inline this-gitBranch :: Text -> Mit Env x ()-gitBranch branch =-  Git.git (Git.Branch Git.FlagNoTrack branch)- -- | Get the head of a local branch (refs/heads/...).-gitBranchHead :: Text -> Mit Env x (Maybe Text)+gitBranchHead :: Text -> Mit Env (Maybe Text) gitBranchHead branch =-  Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify ("refs/heads/" <> branch)) <&> \case+  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 x (Maybe Text)+gitBranchWorktreeDir :: Text -> Mit Env (Maybe Text) gitBranchWorktreeDir branch = do   worktrees <- gitWorktreeList   pure case List.find (\worktree -> worktree.branch == Just branch) worktrees of     Nothing -> Nothing     Just worktree -> Just worktree.directory -gitCommit :: Mit Env x Bool+gitCommit :: Mit Env Bool gitCommit =   io (queryTerminal 0) >>= \case     False -> do@@ -217,7 +211,7 @@         ExitFailure _ -> False         ExitSuccess -> True -gitCommitsBetween :: Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo)+gitCommitsBetween :: Maybe Text -> Text -> Mit Env (Seq GitCommitInfo) gitCommitsBetween commit1 commit2 =   if commit1 == Just commit2     then pure Seq.empty@@ -240,62 +234,67 @@       _ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs       xs -> xs -gitConflicts :: Mit Env x [GitConflict]+gitConflicts :: Mit Env [GitConflict] gitConflicts =-  mapMaybe parseGitConflict <$> Git.git (Git.StatusV1 Git.FlagNoRenames)+  mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"]  -- | Get the conflicts with the given commitish. -- -- Precondition: there is no merge in progress.-gitConflictsWith :: Text -> Mit Env x [GitConflict]+gitConflictsWith :: Text -> Mit Env [GitConflict] gitConflictsWith commit = do   maybeStash <- gitStash   conflicts <- do-    Git.git (Git.Merge Git.FlagNoCommit Git.FlagNoFF commit) >>= \case+    git ["merge", "--no-commit", "--no-ff", commit] >>= \case       False -> gitConflicts       True -> pure []-  whenM gitMergeInProgress (Git.git_ Git.MergeAbort)-  whenJust maybeStash \stash -> Git.git (Git.StashApply Git.FlagQuiet stash)+  whenM gitMergeInProgress (git_ ["merge", "--abort"])+  whenJust maybeStash \stash -> git ["stash", "apply", "--quiet", stash]   pure conflicts  -- | Precondition: there are changes to stash-gitCreateStash :: Mit Env x Text+gitCreateStash :: Mit Env Text gitCreateStash = do-  Git.git_ Git.AddAll -- it seems certain things (like renames), unless staged, cannot be stashed-  stash <- Git.git Git.StashCreate+  git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed+  stash <- git ["stash", "create"]   gitUnstageChanges   pure stash -gitDefaultBranch :: Text -> Mit Env x Text+gitDefaultBranch :: Text -> Mit Env Text gitDefaultBranch remote = do-  ref <- Git.git (Git.SymbolicRef ("refs/remotes/" <> remote <> "/HEAD"))+  ref <- git ["symbolic-ref", "refs/remotes/" <> remote <> "/HEAD"]   pure (Text.drop (14 + Text.length remote) ref) +-- | Delete all changes in the index and working tree.+gitDeleteChanges :: Mit Env ()+gitDeleteChanges =+  git_ ["reset", "--hard", "--quiet", "HEAD"]+ -- FIXME document this-gitDiff :: Mit Env x DiffResult+gitDiff :: Mit Env DiffResult gitDiff = do   gitUnstageChanges-  Git.git (Git.Diff Git.FlagQuiet) <&> \case+  git ["diff", "--quiet"] <&> \case     False -> Differences     True -> NoDifferences -gitExistCommitsBetween :: Text -> Text -> Mit Env x Bool+gitExistCommitsBetween :: Text -> Text -> Mit Env Bool gitExistCommitsBetween commit1 commit2 =   if commit1 == commit2     then pure False     else isJust <$> git ["rev-list", "--max-count=1", commit1 <> ".." <> commit2]  -- | Do any untracked files exist?-gitExistUntrackedFiles :: Mit Env x Bool+gitExistUntrackedFiles :: Mit Env Bool gitExistUntrackedFiles =   not . null <$> gitListUntrackedFiles -gitFetch :: Text -> Mit Env x Bool+gitFetch :: Text -> Mit Env Bool gitFetch remote = do   fetched <- io (readIORef fetchedRef)   case Map.lookup remote fetched of     Nothing -> do-      success <- Git.git (Git.Fetch remote)+      success <- git ["fetch", remote]       io (writeIORef fetchedRef (Map.insert remote success fetched))       pure success     Just success -> pure success@@ -306,64 +305,59 @@   unsafePerformIO (newIORef mempty) {-# NOINLINE fetchedRef #-} -gitFetch_ :: Text -> Mit Env x ()+gitFetch_ :: Text -> Mit Env () gitFetch_ =   void . gitFetch  -- | Get the head commit.-gitHead :: Mit Env x Text+gitHead :: Mit Env Text gitHead =-  Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify "HEAD")+  git ["rev-parse", "HEAD"] -gitIsMergeCommit :: Text -> Mit Env x Bool+-- | Get whether a commit is a merge commit.+gitIsMergeCommit :: Text -> Mit Env Bool gitIsMergeCommit commit =-  Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify (commit <> "^2"))+  git ["rev-parse", "--quiet", "--verify", commit <> "^2"]  -- | List all untracked files.-gitListUntrackedFiles :: Mit Env x [Text]+gitListUntrackedFiles :: Mit Env [Text] gitListUntrackedFiles =   git ["ls-files", "--exclude-standard", "--other"]  -- | Get the head commit, if it exists.-gitMaybeHead :: Mit Env x (Maybe Text)+gitMaybeHead :: Mit Env (Maybe Text) gitMaybeHead =-  Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify "HEAD") <&> \case+  git ["rev-parse", "HEAD"] <&> \case     Left _ -> Nothing     Right commit -> Just commit -gitMergeInProgress :: Mit Env x Bool+-- | Get whether a merge is in progress.+gitMergeInProgress :: Mit Env Bool gitMergeInProgress = do-  env <- getEnv-  io (doesFileExist (Text.unpack (env.gitdir <> "/MERGE_HEAD")))+  gitdir <- gitRevParseAbsoluteGitDir+  io (doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD"))) -gitPush :: Text -> Mit Env x Bool+gitPush :: Text -> Mit Env Bool gitPush branch =   git ["push", "--set-upstream", "origin", "--quiet", branch <> ":" <> branch]  -- | Does the given remote branch (refs/remotes/...) exist?-gitRemoteBranchExists :: Text -> Text -> Mit Env x Bool+gitRemoteBranchExists :: Text -> Text -> Mit Env Bool gitRemoteBranchExists remote branch =-  Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify ("refs/remotes/" <> remote <> "/" <> branch))+  git ["rev-parse", "--quiet", "--verify", "refs/remotes/" <> remote <> "/" <> branch]  -- | Get the head of a remote branch.-gitRemoteBranchHead :: Text -> Text -> Mit Env x (Maybe Text)+gitRemoteBranchHead :: Text -> Text -> Mit Env (Maybe Text) gitRemoteBranchHead remote branch =-  Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify ("refs/remotes/" <> remote <> "/" <> branch)) <&> \case+  git ["rev-parse", "refs/remotes/" <> remote <> "/" <> branch] <&> \case     Left _ -> Nothing     Right head -> Just head -gitRevParseAbsoluteGitDir :: Mit Env x (Maybe Text)+gitRevParseAbsoluteGitDir :: ProcessOutput a => Mit Env a gitRevParseAbsoluteGitDir =-  git ["rev-parse", "--absolute-git-dir"] <&> \case-    Left _ -> Nothing-    Right dir -> Just dir---- | The root of this git worktree.-gitRevParseShowToplevel :: Mit Env x Text-gitRevParseShowToplevel =-  git ["rev-parse", "--show-toplevel"]+  git ["rev-parse", "--absolute-git-dir"] -gitShow :: Text -> Mit Env x GitCommitInfo+gitShow :: Text -> Mit Env GitCommitInfo gitShow commit =   parseGitCommitInfo     <$> git@@ -375,23 +369,24 @@       ]  -- | Stash uncommitted changes (if any).-gitStash :: Mit Env x (Maybe Text)+gitStash :: Mit Env (Maybe Text) gitStash = do   gitDiff >>= \case     Differences -> do       stash <- gitCreateStash-      Git.git_ (Git.Clean Git.FlagD Git.FlagForce)-      Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD")+      git_ ["clean", "-d", "--force"]+      gitDeleteChanges       pure (Just stash)     NoDifferences -> pure Nothing -gitUnstageChanges :: Mit Env x ()+gitUnstageChanges :: Mit Env () gitUnstageChanges = do-  Git.git_ (Git.ResetPaths Git.FlagQuiet ["."])+  git_ ["reset", "--quiet", "--", "."]   untrackedFiles <- gitListUntrackedFiles-  unless (null untrackedFiles) (Git.git_ (Git.Add Git.FlagIntentToAdd untrackedFiles))+  when (not (null untrackedFiles)) do+    git_ ("add" : "--intent-to-add" : untrackedFiles) -gitVersion :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x GitVersion+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@@ -411,7 +406,7 @@  -- /dir/one 0efd393c35 [oingo]         -> ("/dir/one", "0efd393c35", Just "oingo") -- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing)-gitWorktreeList :: Mit Env x [GitWorktree]+gitWorktreeList :: Mit Env [GitWorktree] gitWorktreeList = do   git ["worktree", "list"] <&> map \line ->     case Parsec.parse parser "" line of@@ -450,7 +445,7 @@   url' <- Text.stripSuffix ".git" url   pure (url, Text.takeWhileEnd (/= '/') url') -git :: ProcessOutput a => [Text] -> Mit Env x a+git :: ProcessOutput a => [Text] -> Mit Env a git args = do   let spec :: CreateProcess       spec =@@ -472,14 +467,16 @@             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+      debugPrintGit args stdoutLines stderrLines exitCode (t1 - t0)       io (fromProcessOutput stdoutLines stderrLines exitCode)   where     cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()@@ -501,15 +498,16 @@               signalProcessGroup sigTERM pgid           waitForProcess process -git_ :: [Text] -> Mit Env x ()+git_ :: [Text] -> Mit Env () git_ =   git  -- Yucky interactive/inherity variant (so 'git commit' can open an editor). -- -- FIXME bracket-git2 :: [Text] -> Mit Env x ExitCode+git2 :: [Text] -> Mit Env ExitCode git2 args = do+  t0 <- io getMonotonicTime   (_, _, stderrHandle, processHandle) <-     io do       createProcess@@ -536,19 +534,27 @@       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+  debugPrintGit args Seq.empty stderrLines exitCode (t1 - t0)   pure exitCode -debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()-debugPrintGit args stdoutLines stderrLines exitCode = do+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 <> " git " <> Builder.hcat (map quote args))+    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

@@ -1,263 +0,0 @@--- | Low-level git commands-module Mit.GitCommand-  ( Command (..),-    ResetMode (..),-    FlagD (..),-    FlagForce (..),-    FlagIntentToAdd (..),-    FlagNoCommit (..),-    FlagNoFF (..),-    FlagNoRenames (..),-    FlagNoTrack (..),-    FlagQuiet (..),-    FlagVerify (..),-    git,-    git_,-  )-where--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 Ki qualified-import Mit.Builder qualified as Builder-import Mit.Env (Env (..))-import Mit.Monad-import Mit.Prelude-import Mit.Process-import System.Exit (ExitCode (..))-import System.IO (Handle, hClose, hIsEOF)-import System.Posix.Process (getProcessGroupIDOf)-import System.Posix.Signals-import System.Process-import System.Process.Internals--data Command-  = AddAll-  | Add FlagIntentToAdd [Text]-  | Branch FlagNoTrack Text-  | BranchSetUpstreamTo Text-  | BranchShowCurrent-  | Clean FlagD FlagForce-  | Diff FlagQuiet-  | Fetch Text-  | Merge FlagNoCommit FlagNoFF Text-  | MergeAbort-  | Reset ResetMode FlagQuiet Text-  | ResetPaths FlagQuiet [Text]-  | RevParse FlagQuiet FlagVerify Text-  | StashApply FlagQuiet Text-  | StashCreate-  | StatusV1 FlagNoRenames-  | Switch Text-  | SymbolicRef Text--renderCommand :: Command -> [Text]-renderCommand = \case-  Add intentToAdd files -> ["add"] ++ renderFlagIntentToAdd intentToAdd ++ files-  AddAll -> ["add", "--all"]-  Branch noTrack branch -> ["branch"] ++ renderFlagNoTrack noTrack ++ [branch]-  BranchSetUpstreamTo upstream -> ["branch", "--set-upstream-to", upstream]-  BranchShowCurrent -> ["branch", "--show-current"]-  Clean d force -> ["clean"] ++ renderFlagD d ++ renderFlagForce force-  Diff quiet -> ["diff"] ++ renderFlagQuiet quiet-  Fetch remote -> ["fetch", remote]-  Merge noCommit noFF commit -> ["merge"] ++ renderFlagNoCommit noCommit ++ renderFlagNoFF noFF ++ [commit]-  MergeAbort -> ["merge", "--abort"]-  Reset mode quiet commit -> ["reset", renderResetMode mode] ++ renderFlagQuiet quiet ++ [commit]-  ResetPaths quiet paths -> ["reset"] ++ renderFlagQuiet quiet ++ ["--"] ++ paths-  RevParse quiet verify commit -> ["rev-parse"] ++ renderFlagQuiet quiet ++ renderFlagVerify verify ++ [commit]-  StashApply quiet commit -> ["stash", "apply"] ++ renderFlagQuiet quiet ++ [commit]-  StashCreate -> ["stash", "create"]-  StatusV1 noRenames -> ["status"] ++ renderFlagNoRenames noRenames ++ ["--porcelain=v1"]-  Switch branch -> ["switch", branch]-  SymbolicRef commit -> ["symbolic-ref", commit]--data ResetMode-  = Mixed-  | Hard--renderResetMode :: ResetMode -> Text-renderResetMode = \case-  Mixed -> "--mixed"-  Hard -> "--hard"--data FlagD-  = FlagD-  | NoFlagD--renderFlagD :: FlagD -> [Text]-renderFlagD = \case-  FlagD -> ["-d"]-  NoFlagD -> []--data FlagForce-  = FlagForce-  | NoFlagForce--renderFlagForce :: FlagForce -> [Text]-renderFlagForce = \case-  FlagForce -> ["--force"]-  NoFlagForce -> []--data FlagIntentToAdd-  = FlagIntentToAdd-  | NoFlagIntentToAdd--renderFlagIntentToAdd :: FlagIntentToAdd -> [Text]-renderFlagIntentToAdd = \case-  FlagIntentToAdd -> ["--intent-to-add"]-  NoFlagIntentToAdd -> []--data FlagNoCommit-  = FlagNoCommit-  | NoFlagNoCommit--renderFlagNoCommit :: FlagNoCommit -> [Text]-renderFlagNoCommit = \case-  FlagNoCommit -> ["--no-commit"]-  NoFlagNoCommit -> []--data FlagNoFF-  = FlagNoFF-  | NoFlagNoFF--renderFlagNoFF :: FlagNoFF -> [Text]-renderFlagNoFF = \case-  FlagNoFF -> ["--no-ff"]-  NoFlagNoFF -> []--data FlagNoRenames-  = FlagNoRenames-  | NoFlagNoRenames--renderFlagNoRenames :: FlagNoRenames -> [Text]-renderFlagNoRenames = \case-  FlagNoRenames -> ["--no-renames"]-  NoFlagNoRenames -> []--data FlagNoTrack-  = FlagNoTrack-  | NoFlagNoTrack--renderFlagNoTrack :: FlagNoTrack -> [Text]-renderFlagNoTrack = \case-  FlagNoTrack -> ["--no-track"]-  NoFlagNoTrack -> []--data FlagQuiet-  = FlagQuiet-  | NoFlagQuiet--renderFlagQuiet :: FlagQuiet -> [Text]-renderFlagQuiet = \case-  FlagQuiet -> ["--quiet"]-  NoFlagQuiet -> []--data FlagVerify-  = FlagVerify-  | NoFlagVerify--renderFlagVerify :: FlagVerify -> [Text]-renderFlagVerify = \case-  FlagVerify -> ["--verify"]-  NoFlagVerify -> []----------------------------------------------------------------------------------------------------------------------------- Git process  stuff--git :: ProcessOutput a => Command -> Mit Env x a-git =-  runGit . renderCommand--git_ :: Command -> Mit Env x ()-git_ =-  git--runGit :: ProcessOutput a => [Text] -> Mit Env x a-runGit args = do-  let spec :: CreateProcess-      spec =-        CreateProcess-          { child_group = Nothing,-            child_user = Nothing,-            close_fds = True,-            cmdspec = RawCommand "git" (map Text.unpack args),-            create_group = False,-            cwd = Nothing,-            delegate_ctlc = False,-            env = Nothing,-            new_session = False,-            std_err = CreatePipe,-            std_in = NoStream,-            std_out = CreatePipe,-            -- windows-only-            create_new_console = False,-            detach_console = False,-            use_process_jobs = False-          }--  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)-      stdoutLines <- io (atomically (Ki.await stdoutThread))-      stderrLines <- io (atomically (Ki.await stderrThread))-      debugPrintGit args stdoutLines stderrLines exitCode-      io (fromProcessOutput stdoutLines stderrLines exitCode)-  where-    cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()-    cleanup (maybeStdin, maybeStdout, maybeStderr, process) =-      void @_ @ExitCode terminate `finally` closeHandles-      where-        closeHandles :: IO ()-        closeHandles =-          whenJust maybeStdin hClose-            `finally` whenJust maybeStdout hClose-            `finally` whenJust maybeStderr hClose-        terminate :: IO ExitCode-        terminate = do-          withProcessHandle process \case-            ClosedHandle _ -> pure ()-            OpenExtHandle {} -> bug "OpenExtHandle is Windows-only"-            OpenHandle pid -> do-              pgid <- getProcessGroupIDOf pid-              signalProcessGroup sigTERM pgid-          waitForProcess process--debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()-debugPrintGit args stdoutLines stderrLines exitCode = 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 <> " 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 '✓'--drainTextHandle :: Handle -> IO (Seq Text)-drainTextHandle handle = do-  let loop acc =-        hIsEOF handle >>= \case-          False -> do-            line <- Text.hGetLine handle-            loop $! acc Seq.|> line-          True -> pure acc-  loop Seq.empty

@@ -5,100 +5,86 @@     getEnv,     withEnv,     Goto,-    Label,     label,     with,     with_,-    X,   ) where  import Control.Monad qualified+import Data.Unique import Mit.Prelude+import Unsafe.Coerce (unsafeCoerce) -newtype Mit r x a-  = Mit (r -> (a -> IO x) -> IO x)+newtype Mit r a+  = Mit (forall x. r -> (a -> IO x) -> IO x)   deriving stock (Functor) -instance Applicative (Mit r x) where+instance Applicative (Mit r) where   pure x = Mit \_ k -> k x   (<*>) = ap -instance Monad (Mit r x) where+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 x) where+instance MonadIO (Mit r) where   liftIO = io -unMit :: Mit r x a -> r -> (a -> IO x) -> IO x+unMit :: Mit r a -> r -> (a -> IO x) -> IO x unMit (Mit k) =   k -runMit :: r -> Mit r a a -> IO a+runMit :: r -> Mit r a -> IO a runMit r m =   unMit m r pure -return :: x -> Mit r x a-return x =-  Mit \_ _ -> pure x--io :: IO a -> Mit r x a+io :: IO a -> Mit r a io m =   Mit \_ k -> do     x <- m     k x -getEnv :: Mit r x r+getEnv :: Mit r r getEnv =   Mit \r k -> k r -withEnv :: (r -> s) -> Mit s x a -> Mit r x a+withEnv :: (r -> s) -> Mit s a -> Mit r a withEnv f m =   Mit \r k -> unMit m (f r) k -type Goto r x a =-  forall xx void. Label (X x a) xx => a -> Mit r xx void+type Goto r a =+  forall void. a -> Mit r void -label :: forall r x a. (Goto r x a -> Mit r (X x a) a) -> Mit r x a+label :: (Goto r a -> Mit r a) -> Mit r a label f =   Mit \r k -> do-    unX k (unMit (f \a -> return (bury @(X x a) (XR a))) r (pure . XR))--with :: (forall v. (a -> IO v) -> IO v) -> (a -> Mit r (X x b) b) -> Mit r x b-with f action =-  Mit \r k ->-    unX k (f \a -> unMit (action a) r (pure . XR))--with_ :: (forall v. IO v -> IO v) -> Mit r (X x a) a -> Mit r x a-with_ f action =-  Mit \r k ->-    unX k (f (unMit action r (pure . XR)))---- instance Label (X a b) (X a b)--- instance Label (X a b) (X (X a b) c)--- instance Label (X a b) (X (X (X a b) c) d)--- etc...+    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 a b-  = XL a-  | XR b+data X = forall a. X Unique a -unX :: (a -> IO b) -> IO (X b a) -> IO b-unX k mx =-  mx >>= \case-    XL b -> pure b-    XR a -> k a+instance Exception X where+  toException = asyncExceptionToException+  fromException = asyncExceptionFromException -class Label a b where-  bury :: a -> b-  default bury :: a ~ b => a -> b-  bury = id+instance Show X where+  show _ = "" --- FIXME I don't really think this is correct...-instance {-# INCOHERENT #-} Label (X a b) (X a b)+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 -instance Label (X a b) (X c d) => Label (X a b) (X (X c d) e) where-  bury = XL . bury+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

@@ -28,7 +28,7 @@ emptyMitState =   MitState {head = (), merging = Nothing, undos = []} -deleteMitState :: Text -> Mit Env x ()+deleteMitState :: Text -> Mit Env () deleteMitState branch64 = do   mitfile <- getMitfile branch64   io (removeFile mitfile `catch` \(_ :: IOException) -> pure ())@@ -45,7 +45,7 @@   undos <- Text.stripPrefix "undos " undosLine >>= parseUndos   pure MitState {head, merging, undos} -readMitState :: Text -> Mit Env x (MitState ())+readMitState :: Text -> Mit Env (MitState ()) readMitState branch =   label \return -> do     head <-@@ -71,7 +71,7 @@   where     branch64 = Text.encodeBase64 branch -writeMitState :: Text -> MitState () -> Mit Env x ()+writeMitState :: Text -> MitState () -> Mit Env () writeMitState branch state = do   head <- gitHead   let contents :: Text@@ -84,7 +84,7 @@   mitfile <- getMitfile (Text.encodeBase64 branch)   io (Text.writeFile mitfile contents `catch` \(_ :: IOException) -> pure ()) -getMitfile :: Text -> Mit Env x FilePath+getMitfile :: Text -> Mit Env FilePath getMitfile branch64 = do-  env <- getEnv-  pure (Text.unpack (env.gitdir <> "/.mit-" <> branch64))+  gitdir <- gitRevParseAbsoluteGitDir+  pure (Text.unpack (gitdir <> "/.mit-" <> branch64))

@@ -43,7 +43,7 @@           error (show text)         ] -applyUndo :: Undo -> Mit Env x ()+applyUndo :: Undo -> Mit Env () applyUndo = \case   Apply commit -> do     git_ ["stash", "apply", "--quiet", commit]