packages feed

mit-3qvpPyAi6mH 9 → 10

raw patch · 10 files changed

+375/−232 lines, 10 filesdep ~basedep ~containersdep ~directory

Dependency ranges changed: base, containers, directory, ki, process, stm, text, unix

Files

mit-3qvpPyAi6mH.cabal view
@@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX-version: 9+version: 10  description:   A git wrapper with a streamlined UX.@@ -19,7 +19,7 @@   To install the @mit@ command-line tool, run the following:    @-  cabal install -w ghc-9.2.2 mit-3qvpPyAi6mH+  cabal install mit-3qvpPyAi6mH   @    This package's library component does not follow the Package Versioning Policy.@@ -32,14 +32,17 @@   default-extensions:     BlockArguments     DataKinds+    DefaultSignatures     DeriveFunctor     DerivingStrategies     DuplicateRecordFields+    FlexibleContexts     FlexibleInstances     GADTs     GeneralizedNewtypeDeriving     ImportQualifiedPost     LambdaCase+    ImportQualifiedPost     MultiParamTypeClasses     MultiWayIf     NamedFieldPuns@@ -53,6 +56,7 @@     ScopedTypeVariables     TupleSections     TypeApplications+    TypeOperators     UndecidableInstances     ViewPatterns   default-language: Haskell2010@@ -68,22 +72,23 @@ library   import: component   build-depends:-    base == 4.16.1.0 || == 4.16.2.0,+    base ^>= 4.16 || ^>= 4.17,     base64 == 0.4.2.4,-    containers == 0.6.5.1,-    directory == 1.3.7.0,-    ki == 1.0.0,+    containers == 0.6.6,+    directory == 1.3.7.1,+    ki == 1.0.0.1,     optparse-applicative == 0.17.0.0,     parsec == 3.1.15.1,-    process == 1.6.14.0,-    stm == 2.5.0.2,-    text == 1.2.5.0,+    process == 1.6.15.0,+    stm == 2.5.1.0,+    text == 2.0.1,     text-ansi == 0.1.1,-    unix == 2.7.2.2,+    unix == 2.7.3,   exposed-modules:     Mit     Mit.Builder     Mit.Directory+    Mit.Env     Mit.Git     Mit.GitCommand     Mit.Monad
src/Mit.hs view
@@ -12,6 +12,7 @@ import Data.Text.Lazy.Builder qualified as Text.Builder import Mit.Builder qualified as Builder import Mit.Directory+import Mit.Env import Mit.Git import Mit.GitCommand qualified as Git import Mit.Monad@@ -32,7 +33,6 @@ -- TODO mit init -- TODO mit delete-branch -- TODO tweak things to work with git < 2.30.1--- TODO rewrite mit commit algorithm in readme -- TODO git(hub,lab) flow or something? -- TODO 'mit branch' with dirty working directory - apply changes to new worktree? -- TODO undo in more cases?@@ -43,8 +43,26 @@  main :: IO () main = do-  (verbosity, action) <- Opt.customExecParser parserPrefs parserInfo-  runMit (clamp (0, 2) verbosity) ([] <$ action) >>= \case+  (verbosity, command) <- Opt.customExecParser parserPrefs parserInfo++  let action :: forall x. Mit () x [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 $> []+              )++  runMit () action >>= \case     [] -> pure ()     errs -> do       putStanzas errs@@ -64,46 +82,55 @@           prefTabulateFill = 24 -- grabbed this from optparse-applicative         } -    parserInfo :: Opt.ParserInfo (Int, Mit Int [Stanza] ())+    parserInfo :: Opt.ParserInfo (Int, MitCommand)     parserInfo =       Opt.info parser $         Opt.progDesc "mit: a git wrapper with a streamlined UX" -    parser :: Opt.Parser (Int, Mit Int [Stanza] ())+    parser :: Opt.Parser (Int, MitCommand)     parser =       (,)-        <$> Opt.option Opt.auto (Opt.help "Verbosity" <> Opt.metavar "«n»" <> Opt.short 'v' <> Opt.value 0)+        <$> ( clamp (0, 2)+                <$> Opt.option Opt.auto (Opt.help "Verbosity" <> Opt.metavar "«n»" <> Opt.short 'v' <> Opt.value 0)+            )         <*> (Opt.hsubparser . fold)           [ Opt.command "branch" $               Opt.info-                (mitBranch <$> Opt.strArgument (Opt.metavar "≪branch≫"))+                (MitCommand'Branch <$> Opt.strArgument (Opt.metavar "≪branch≫"))                 (Opt.progDesc "Create a new branch in a new worktree."),             Opt.command "commit" $               Opt.info-                (pure mitCommit)+                (pure MitCommand'Commit)                 (Opt.progDesc "Create a commit interactively."),             Opt.command "merge" $               Opt.info-                (mitMerge <$> Opt.strArgument (Opt.metavar "≪branch≫"))+                (MitCommand'Merge <$> Opt.strArgument (Opt.metavar "≪branch≫"))                 (Opt.progDesc "Merge the given branch into the current branch."),             Opt.command "sync" $               Opt.info-                (pure mitSync)+                (pure MitCommand'Sync)                 (Opt.progDesc "Sync with the remote named `origin`."),             Opt.command "undo" $               Opt.info-                (pure mitUndo)+                (pure MitCommand'Undo)                 (Opt.progDesc "Undo the last `mit` command (if possible).")           ] -dieIfBuggyGit :: Mit Int [Stanza] ()-dieIfBuggyGit = do-  version <- gitVersion+data MitCommand+  = MitCommand'Branch Text+  | MitCommand'Commit+  | MitCommand'Merge Text+  | MitCommand'Sync+  | MitCommand'Undo++dieIfBuggyGit :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+dieIfBuggyGit return = do+  version <- gitVersion return   let validate (ver, err) = if version < ver then ((ver, err) :) else id   case foldr validate [] validations of     [] -> pure ()     errors ->-      throw $+      return $         map           ( \(ver, err) ->               Just@@ -133,20 +160,15 @@         )       ] -dieIfMergeInProgress :: Mit Int [Stanza] ()-dieIfMergeInProgress =-  whenM gitMergeInProgress (throw [Just (Text.red (Text.bold "git merge" <> " in progress."))])--dieIfNotInGitDir :: Mit Int [Stanza] ()-dieIfNotInGitDir = do-  ublock gitRevParseAbsoluteGitDir >>= \case-    Left _ -> throw [Just (Text.red "The current directory doesn't contain a git repository.")]-    Right _ -> pure ()--mitBranch :: Text -> Mit Int [Stanza] ()-mitBranch branch = do-  dieIfNotInGitDir+dieIfMergeInProgress :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()+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 return branch = do   worktreeDir <- do     rootdir <- gitRevParseShowToplevel     pure (Text.dropWhileEnd (/= '/') rootdir <> branch)@@ -154,10 +176,9 @@   gitBranchWorktreeDir branch >>= \case     Nothing -> do       whenM (doesDirectoryExist worktreeDir) do-        throw [Just (Text.red ("Directory " <> Text.bold (Text.Builder.fromText worktreeDir) <> " already exists."))]+        return [Just (Text.red ("Directory " <> Text.bold (Text.Builder.fromText worktreeDir) <> " already exists."))]       git_ ["worktree", "add", "--detach", worktreeDir]-      block do-        cd worktreeDir+      cd worktreeDir do         whenNotM (Git.git (Git.Switch branch)) do           gitBranch branch           Git.git_ (Git.Switch branch)@@ -168,7 +189,7 @@             Git.git_ (Git.BranchSetUpstreamTo upstream)     Just directory ->       when (directory /= worktreeDir) do-        throw+        return           [ Just               ( Text.red                   ( Text.bold@@ -181,20 +202,19 @@               )           ] -mitCommit :: Mit Int [Stanza] ()-mitCommit = do-  dieIfNotInGitDir-  whenM gitExistUntrackedFiles dieIfBuggyGit+mitCommit :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+mitCommit return = do+  whenM gitExistUntrackedFiles (dieIfBuggyGit @x return)    gitMergeInProgress >>= \case     False ->       gitDiff >>= \case-        Differences -> mitCommit_-        NoDifferences -> throw [Just (Text.red "There's nothing to commit.")]+        Differences -> mitCommit_ return+        NoDifferences -> return [Just (Text.red "There's nothing to commit.")]     True -> mitCommitMerge -mitCommit_ :: Mit Int [Stanza] ()-mitCommit_ = do+mitCommit_ :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x ()+mitCommit_ return = do   context <- getContext   let upstream = "origin/" <> context.branch @@ -202,7 +222,7 @@   existLocalCommits <- contextExistLocalCommits context    when (existRemoteCommits && not existLocalCommits) do-    throw+    return       [ notSynchronizedStanza context.branch upstream ".",         runSyncStanza "Run" context.branch upstream       ]@@ -218,12 +238,17 @@             undos =               case (pushPushed push, committed) of                 (False, False) -> context.state.undos-                (False, True) -> undoToSnapshot context.snapshot+                (False, True) ->+                  case context.snapshot of+                    Nothing -> []+                    Just snapshot -> undoToSnapshot snapshot                 (True, False) -> push.undo                 (True, True) ->                   if null push.undo                     then []-                    else push.undo ++ [Apply (fromJust context.snapshot.stash)]+                    else case context.snapshot of+                      Nothing -> push.undo+                      Just snapshot -> push.undo ++ [Apply (fromJust snapshot.stash)]           }    writeMitState context.branch state@@ -274,8 +299,8 @@                         <> "."                   ]           TriedToPush -> runSyncStanza "Run" context.branch upstream,-        -- Whether we say we can undo from here is not exactly if the state says we can undo, because of one corner case:-        -- we ran 'mit commit', then aborted the commit, and ultimately didn't push any other local changes.+        -- 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@@ -283,7 +308,7 @@         if not (null state.undos) && committed then canUndoStanza else Nothing       ] -mitCommitMerge :: Mit Int x ()+mitCommitMerge :: Mit Env x () mitCommitMerge = do   context <- getContext @@ -311,12 +336,12 @@   --   2. We had a clean working directory before `mit merge`, so proceed to sync    case undosStash context.state.undos of-    Nothing -> mitSyncWith stanza0 (Just [Reset context.snapshot.head])+    Nothing -> mitSyncWith stanza0 (Just [Reset (fromJust context.snapshot).head])     Just stash -> do       conflicts <- gitApplyStash stash       case List1.nonEmpty conflicts of         -- FIXME we just unstashed, now we're about to stash again :/-        Nothing -> mitSyncWith stanza0 (Just [Reset context.snapshot.head, Apply stash])+        Nothing -> mitSyncWith stanza0 (Just [Reset (fromJust context.snapshot).head, Apply stash])         Just conflicts1 ->           io do             putStanzas@@ -339,11 +364,10 @@   | 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 :: Text -> Mit Int [Stanza] ()-mitMerge target = do-  dieIfNotInGitDir-  dieIfMergeInProgress-  whenM gitExistUntrackedFiles dieIfBuggyGit+mitMerge :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Text -> Mit Env xx ()+mitMerge return target = do+  dieIfMergeInProgress return+  whenM gitExistUntrackedFiles (dieIfBuggyGit @x return)    context <- getContext   let upstream = "origin/" <> context.branch@@ -351,16 +375,16 @@   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 context target+    else mitMergeWith @x return context target -mitMergeWith :: Context -> Text -> Mit Int [Stanza] ()-mitMergeWith context target = do+mitMergeWith :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Context -> Text -> Mit Env xx ()+mitMergeWith return context target = do   -- When given 'mit merge foo', prefer running 'git merge origin/foo' over 'git merge foo'   targetCommit <-     gitRemoteBranchHead "origin" target       & onNothingM         ( gitBranchHead target-            & onNothingM (throw [Just (Text.red "No such branch.")])+            & onNothingM (return [Just (Text.red "No such branch.")])         )    let upstream = "origin/" <> context.branch@@ -369,19 +393,19 @@   existLocalCommits <- contextExistLocalCommits context    when (existRemoteCommits && not existLocalCommits) do-    throw+    return       [ notSynchronizedStanza context.branch upstream ".",         runSyncStanza "Run" context.branch upstream       ] -  whenJust context.snapshot.stash \_stash ->+  whenJust (contextStash context) \_stash ->     Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD")    merge <- performMerge ("⅄ " <> target <> " → " <> context.branch) targetCommit    stashConflicts <-     if null merge.conflicts-      then case context.snapshot.stash of+      then case contextStash context of         Nothing -> pure []         Just stash -> gitApplyStash stash       else pure []@@ -398,7 +422,9 @@             undos =               if pushPushed push || Seq.null merge.commits                 then []-                else undoToSnapshot context.snapshot+                else case context.snapshot of+                  Nothing -> []+                  Just snapshot -> undoToSnapshot snapshot           }    writeMitState context.branch state@@ -468,11 +494,10 @@       ]  -- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream-mitSync :: Mit Int [Stanza] ()-mitSync = do-  dieIfNotInGitDir-  dieIfMergeInProgress-  whenM gitExistUntrackedFiles dieIfBuggyGit+mitSync :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+mitSync return = do+  dieIfMergeInProgress return+  whenM gitExistUntrackedFiles (dieIfBuggyGit @x return)   mitSyncWith Nothing Nothing  -- | @mitSyncWith _ maybeUndos@@@ -495,12 +520,12 @@ -- -- 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 Int x ()+mitSyncWith :: Stanza -> Maybe [Undo] -> Mit Env x () mitSyncWith stanza0 maybeUndos = do   context <- getContext   let upstream = "origin/" <> context.branch -  whenJust context.snapshot.stash \_stash ->+  whenJust (contextStash context) \_stash ->     Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD")    merge <-@@ -511,7 +536,7 @@    stashConflicts <-     if null merge.conflicts-      then case context.snapshot.stash of+      then case contextStash context of         Nothing -> pure []         Just stash -> gitApplyStash stash       else pure []@@ -532,7 +557,9 @@                   Nothing ->                     if Seq.null merge.commits                       then []-                      else undoToSnapshot context.snapshot+                      else case context.snapshot of+                        Nothing -> []+                        Just snapshot -> undoToSnapshot snapshot                   -- FIXME hm, could consider appending those undos instead, even if they obviate the recent stash/merge                   -- undos                   Just undos' -> undos'@@ -583,14 +610,13 @@       ]  -- FIXME output what we just undid-mitUndo :: Mit Int [Stanza] ()-mitUndo = do-  dieIfNotInGitDir+mitUndo :: forall x xx. Label (X x [Stanza]) xx => Goto Env x [Stanza] -> Mit Env xx ()+mitUndo return = do   context <- getContext   case List1.nonEmpty context.state.undos of-    Nothing -> throw [Just (Text.red "Nothing to undo.")]+    Nothing -> return [Just (Text.red "Nothing to undo.")]     Just undos1 -> for_ undos1 applyUndo-  when (undosContainRevert context.state.undos) mitSync+  when (undosContainRevert context.state.undos) (mitSync @x return)   where     undosContainRevert :: [Undo] -> Bool     undosContainRevert = \case@@ -713,12 +739,12 @@  data Context = Context   { branch :: Text,-    snapshot :: GitSnapshot,+    snapshot :: Maybe GitSnapshot, -- Nothing when no commits yet     state :: MitState (),     upstreamHead :: Maybe Text   } -getContext :: Mit Int x Context+getContext :: Mit Env x Context getContext = do   gitFetch_ "origin"   branch <- Git.git Git.BranchShowCurrent@@ -727,18 +753,29 @@   snapshot <- performSnapshot   pure Context {branch, snapshot, state, upstreamHead} -contextExistLocalCommits :: Context -> Mit Int x Bool+contextExistLocalCommits :: Context -> Mit Env x Bool contextExistLocalCommits context =   case context.upstreamHead of     Nothing -> pure True-    Just upstreamHead -> gitExistCommitsBetween upstreamHead context.snapshot.head+    Just upstreamHead ->+      case context.snapshot of+        Nothing -> pure False+        Just snapshot -> gitExistCommitsBetween upstreamHead snapshot.head -contextExistRemoteCommits :: Context -> Mit Int x Bool+contextExistRemoteCommits :: Context -> Mit Env x Bool contextExistRemoteCommits context =   case context.upstreamHead of     Nothing -> pure False-    Just upstreamHead -> gitExistCommitsBetween context.snapshot.head upstreamHead+    Just upstreamHead ->+      case context.snapshot of+        Nothing -> pure True+        Just snapshot -> gitExistCommitsBetween snapshot.head upstreamHead +contextStash :: Context -> Maybe Text+contextStash context = do+  snapshot <- context.snapshot+  snapshot.stash+ ------------------------------------------------------------------------------------------------------------------------ -- Git merge @@ -757,7 +794,7 @@ -- conflicts. -- -- Precondition: the working directory is clean. TODO take unused GitStash as argument?-performMerge :: Text -> Text -> Mit Int x GitMerge+performMerge :: Text -> Text -> Mit Env x GitMerge performMerge message commitish = do   head <- gitHead   commits <- gitCommitsBetween (Just head) commitish@@ -799,7 +836,7 @@     TriedToPush -> False  -- TODO get context-performPush :: Text -> Mit Int x GitPush+performPush :: Text -> Mit Env x GitPush performPush branch = do   fetched <- gitFetch "origin"   head <- gitHead@@ -836,14 +873,16 @@     stash :: Maybe Text   } -performSnapshot :: Mit Int x GitSnapshot+performSnapshot :: Mit Env x (Maybe GitSnapshot) performSnapshot = do-  head <- gitHead-  stash <--    gitDiff >>= \case-      Differences -> Just <$> gitCreateStash-      NoDifferences -> pure Nothing-  pure GitSnapshot {head, stash}+  gitMaybeHead >>= \case+    Nothing -> pure Nothing+    Just head -> do+      stash <-+        gitDiff >>= \case+          Differences -> Just <$> gitCreateStash+          NoDifferences -> pure Nothing+      pure (Just GitSnapshot {head, stash})  undoToSnapshot :: GitSnapshot -> [Undo] undoToSnapshot snapshot =
src/Mit/Directory.hs view
@@ -9,9 +9,9 @@ import Mit.Prelude import System.Directory qualified as Directory -cd :: Text -> Mit r x ()+cd :: Text -> Mit r (X x a) a -> Mit r x a cd dir =-  acquire_ (Directory.withCurrentDirectory (Text.unpack dir))+  with_ (Directory.withCurrentDirectory (Text.unpack dir))  -- | Change directories (delimited by 'block'). doesDirectoryExist :: MonadIO m => Text -> m Bool
+ src/Mit/Env.hs view
@@ -0,0 +1,11 @@+module Mit.Env+  ( Env (..),+  )+where++import Mit.Prelude++data Env = Env+  { gitdir :: Text,+    verbosity :: Int+  }
src/Mit/Git.hs view
@@ -1,5 +1,45 @@ -- | High-level git operations-module Mit.Git where+module Mit.Git+  ( DiffResult (..),+    GitCommitInfo,+    prettyGitCommitInfo,+    GitConflict,+    showGitConflict,+    GitVersion (..),+    showGitVersion,+    git,+    git_,+    gitApplyStash,+    gitBranch,+    gitBranchHead,+    gitBranchWorktreeDir,+    gitCommit,+    gitCommitsBetween,+    gitConflicts,+    gitConflictsWith,+    gitCreateStash,+    gitDiff,+    gitExistCommitsBetween,+    gitExistUntrackedFiles,+    gitFetch,+    gitFetch_,+    gitHead,+    gitIsMergeCommit,+    gitMaybeHead,+    gitMergeInProgress,+    gitPush,+    gitRemoteBranchExists,+    gitRemoteBranchHead,+    gitRevParseAbsoluteGitDir,+    gitRevParseShowToplevel,+    gitUnstageChanges,+    gitVersion,+    -- unused, but useful? not sure+    gitDefaultBranch,+    gitShow,+    parseGitRepo,+  )+where  import Data.List qualified as List import Data.Map.Strict qualified as Map@@ -11,6 +51,7 @@ import Data.Text.Lazy.Builder qualified as Text.Builder 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@@ -135,7 +176,7 @@   Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z)  -- | Apply stash, return conflicts.-gitApplyStash :: Text -> Mit Int x [GitConflict]+gitApplyStash :: Text -> Mit Env x [GitConflict] gitApplyStash stash = do   conflicts <-     Git.git (Git.StashApply Git.FlagQuiet stash) >>= \case@@ -146,31 +187,26 @@  -- | Create a branch. -- FIXME inline this-gitBranch :: Text -> Mit Int x ()+gitBranch :: Text -> Mit Env x () gitBranch branch =   Git.git (Git.Branch Git.FlagNoTrack branch) --- | Does the given local branch (refs/heads/...) exist?-gitBranchExists :: Text -> Mit Int x Bool-gitBranchExists branch =-  Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify ("refs/heads/" <> branch))- -- | Get the head of a local branch (refs/heads/...).-gitBranchHead :: Text -> Mit Int x (Maybe Text)+gitBranchHead :: Text -> Mit Env x (Maybe Text) gitBranchHead branch =   Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify ("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 Int x (Maybe Text)+gitBranchWorktreeDir :: Text -> Mit Env x (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 Int x Bool+gitCommit :: Mit Env x Bool gitCommit =   io (queryTerminal 0) >>= \case     False -> do@@ -181,7 +217,7 @@         ExitFailure _ -> False         ExitSuccess -> True -gitCommitsBetween :: Maybe Text -> Text -> Mit Int x (Seq GitCommitInfo)+gitCommitsBetween :: Maybe Text -> Text -> Mit Env x (Seq GitCommitInfo) gitCommitsBetween commit1 commit2 =   if commit1 == Just commit2     then pure Seq.empty@@ -204,17 +240,17 @@       _ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs       xs -> xs -gitConflicts :: Mit Int x [GitConflict]+gitConflicts :: Mit Env x [GitConflict] gitConflicts =   mapMaybe parseGitConflict <$> Git.git (Git.StatusV1 Git.FlagNoRenames)  -- | Get the conflicts with the given commitish. -- -- Precondition: there is no merge in progress.-gitConflictsWith :: Text -> Mit Int x [GitConflict]+gitConflictsWith :: Text -> Mit Env x [GitConflict] gitConflictsWith commit = do   maybeStash <- gitStash-  conflicts <-+  conflicts <- do     Git.git (Git.Merge Git.FlagNoCommit Git.FlagNoFF commit) >>= \case       False -> gitConflicts       True -> pure []@@ -223,38 +259,38 @@   pure conflicts  -- | Precondition: there are changes to stash-gitCreateStash :: Mit Int x Text+gitCreateStash :: Mit Env x Text gitCreateStash = do   Git.git_ Git.AddAll -- it seems certain things (like renames), unless staged, cannot be stashed   stash <- Git.git Git.StashCreate   gitUnstageChanges   pure stash -gitDefaultBranch :: Text -> Mit Int x Text+gitDefaultBranch :: Text -> Mit Env x Text gitDefaultBranch remote = do   ref <- Git.git (Git.SymbolicRef ("refs/remotes/" <> remote <> "/HEAD"))   pure (Text.drop (14 + Text.length remote) ref)  -- FIXME document this-gitDiff :: Mit Int x DiffResult+gitDiff :: Mit Env x DiffResult gitDiff = do   gitUnstageChanges   Git.git (Git.Diff Git.FlagQuiet) <&> \case     False -> Differences     True -> NoDifferences -gitExistCommitsBetween :: Text -> Text -> Mit Int x Bool+gitExistCommitsBetween :: Text -> Text -> Mit Env x 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 Int x Bool+gitExistUntrackedFiles :: Mit Env x Bool gitExistUntrackedFiles =   not . null <$> gitListUntrackedFiles -gitFetch :: Text -> Mit Int x Bool+gitFetch :: Text -> Mit Env x Bool gitFetch remote = do   fetched <- io (readIORef fetchedRef)   case Map.lookup remote fetched of@@ -270,54 +306,64 @@   unsafePerformIO (newIORef mempty) {-# NOINLINE fetchedRef #-} -gitFetch_ :: Text -> Mit Int x ()+gitFetch_ :: Text -> Mit Env x () gitFetch_ =   void . gitFetch -gitHead :: Mit Int x Text+-- | Get the head commit.+gitHead :: Mit Env x Text gitHead =   Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify "HEAD") -gitIsMergeCommit :: Text -> Mit Int x Bool+gitIsMergeCommit :: Text -> Mit Env x Bool gitIsMergeCommit commit =   Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify (commit <> "^2"))  -- | List all untracked files.-gitListUntrackedFiles :: Mit Int x [Text]+gitListUntrackedFiles :: Mit Env x [Text] gitListUntrackedFiles =   git ["ls-files", "--exclude-standard", "--other"] -gitMergeInProgress :: Mit Int x Bool+-- | Get the head commit, if it exists.+gitMaybeHead :: Mit Env x (Maybe Text)+gitMaybeHead =+  Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify "HEAD") <&> \case+    Left _ -> Nothing+    Right commit -> Just commit++gitMergeInProgress :: Mit Env x Bool gitMergeInProgress = do-  gitdir <- gitRevParseAbsoluteGitDir-  io (doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD")))+  env <- getEnv+  io (doesFileExist (Text.unpack (env.gitdir <> "/MERGE_HEAD"))) -gitPush :: Text -> Mit Int x Bool+gitPush :: Text -> Mit Env x Bool gitPush branch =   git ["push", "--set-upstream", "origin", "--quiet", branch <> ":" <> branch]  -- | Does the given remote branch (refs/remotes/...) exist?-gitRemoteBranchExists :: Text -> Text -> Mit Int x Bool+gitRemoteBranchExists :: Text -> Text -> Mit Env x Bool gitRemoteBranchExists remote branch =   Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify ("refs/remotes/" <> remote <> "/" <> branch))  -- | Get the head of a remote branch.-gitRemoteBranchHead :: Text -> Text -> Mit Int x (Maybe Text)+gitRemoteBranchHead :: Text -> Text -> Mit Env x (Maybe Text) gitRemoteBranchHead remote branch =   Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify ("refs/remotes/" <> remote <> "/" <> branch)) <&> \case     Left _ -> Nothing     Right head -> Just head -gitRevParseAbsoluteGitDir :: Mit Int x Text+gitRevParseAbsoluteGitDir :: Mit Env x (Maybe Text) gitRevParseAbsoluteGitDir =-  git ["rev-parse", "--absolute-git-dir"]+  git ["rev-parse", "--absolute-git-dir"] <&> \case+    Left _ -> Nothing+    Right dir -> Just dir  -- | The root of this git worktree.-gitRevParseShowToplevel :: Mit Int x Text+gitRevParseShowToplevel :: Mit Env x Text gitRevParseShowToplevel =   git ["rev-parse", "--show-toplevel"] -gitShow :: Text -> Mit Int x GitCommitInfo+gitShow :: Text -> Mit Env x GitCommitInfo gitShow commit =   parseGitCommitInfo     <$> git@@ -329,7 +375,7 @@       ]  -- | Stash uncommitted changes (if any).-gitStash :: Mit Int x (Maybe Text)+gitStash :: Mit Env x (Maybe Text) gitStash = do   gitDiff >>= \case     Differences -> do@@ -339,16 +385,16 @@       pure (Just stash)     NoDifferences -> pure Nothing -gitUnstageChanges :: Mit Int x ()+gitUnstageChanges :: Mit Env x () gitUnstageChanges = do   Git.git_ (Git.ResetPaths Git.FlagQuiet ["."])   untrackedFiles <- gitListUntrackedFiles   unless (null untrackedFiles) (Git.git_ (Git.Add Git.FlagIntentToAdd untrackedFiles)) -gitVersion :: Mit Int [Stanza] GitVersion-gitVersion = do+gitVersion :: (forall void. [Stanza] -> Mit Env x void) -> Mit Env x GitVersion+gitVersion return = do   v0 <- git ["--version"]-  fromMaybe (throw [Just ("Could not parse git version from: " <> Text.Builder.fromText v0)]) do+  fromMaybe (return [Just ("Could not parse git version from: " <> Text.Builder.fromText v0)]) do     "git" : "version" : v1 : _ <- Just (Text.words v0)     [sx, sy, sz] <- Just (Text.split (== '.') v1)     x <- readMaybe (Text.unpack sx)@@ -365,7 +411,7 @@  -- /dir/one 0efd393c35 [oingo]         -> ("/dir/one", "0efd393c35", Just "oingo") -- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing)-gitWorktreeList :: Mit Int x [GitWorktree]+gitWorktreeList :: Mit Env x [GitWorktree] gitWorktreeList = do   git ["worktree", "list"] <&> map \line ->     case Parsec.parse parser "" line of@@ -404,7 +450,7 @@   url' <- Text.stripSuffix ".git" url   pure (url, Text.takeWhileEnd (/= '/') url') -git :: ProcessOutput a => [Text] -> Mit Int x a+git :: ProcessOutput a => [Text] -> Mit Env x a git args = do   let spec :: CreateProcess       spec =@@ -426,16 +472,15 @@             detach_console = False,             use_process_jobs = False           }-  block do-    (_maybeStdin, maybeStdout, maybeStderr, processHandle) <- acquire (bracket (createProcess spec) cleanup)-    scope <- acquire Ki.scoped-    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)+  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) =@@ -456,14 +501,14 @@               signalProcessGroup sigTERM pgid           waitForProcess process -git_ :: [Text] -> Mit Int x ()+git_ :: [Text] -> Mit Env x () git_ =   git  -- Yucky interactive/inherity variant (so 'git commit' can open an editor). -- -- FIXME bracket-git2 :: [Text] -> Mit Int x ExitCode+git2 :: [Text] -> Mit Env x ExitCode git2 args = do   (_, _, stderrHandle, processHandle) <-     io do@@ -495,10 +540,10 @@   debugPrintGit args Seq.empty stderrLines exitCode   pure exitCode -debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Int x ()+debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x () debugPrintGit args stdoutLines stderrLines exitCode = do-  verbose <- getEnv-  io case verbose of+  env <- getEnv+  io case env.verbosity of     1 -> Builder.putln (Text.Builder.brightBlack v1)     2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2))     _ -> pure ()
src/Mit/GitCommand.hs view
@@ -24,6 +24,7 @@ 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@@ -168,15 +169,15 @@ ------------------------------------------------------------------------------------------------------------------------ -- Git process  stuff -git :: ProcessOutput a => Command -> Mit Int x a+git :: ProcessOutput a => Command -> Mit Env x a git =   runGit . renderCommand -git_ :: Command -> Mit Int x ()+git_ :: Command -> Mit Env x () git_ =   git -runGit :: ProcessOutput a => [Text] -> Mit Int x a+runGit :: ProcessOutput a => [Text] -> Mit Env x a runGit args = do   let spec :: CreateProcess       spec =@@ -198,16 +199,16 @@             detach_console = False,             use_process_jobs = False           }-  block do-    (_maybeStdin, maybeStdout, maybeStderr, processHandle) <- acquire (bracket (createProcess spec) cleanup)-    scope <- acquire Ki.scoped-    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)++  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) =@@ -228,10 +229,10 @@               signalProcessGroup sigTERM pgid           waitForProcess process -debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Int x ()+debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x () debugPrintGit args stdoutLines stderrLines exitCode = do-  verbose <- getEnv-  io case verbose of+  env <- getEnv+  io case env.verbosity of     1 -> Builder.putln (Text.Builder.brightBlack v1)     2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2))     _ -> pure ()
src/Mit/Monad.hs view
@@ -3,71 +3,102 @@     runMit,     io,     getEnv,-    throw,-    acquire,-    acquire_,-    block,-    ublock,+    withEnv,+    Goto,+    Label,+    label,+    with,+    with_,+    X,   ) where +import Control.Monad qualified import Mit.Prelude  newtype Mit r x a-  = Mit ((a -> r -> IO x) -> r -> IO x)+  = Mit (r -> (a -> IO x) -> IO x)   deriving stock (Functor)  instance Applicative (Mit r x) where-  pure x = Mit \k r -> k x r+  pure x = Mit \_ k -> k x   (<*>) = ap  instance Monad (Mit r x) where   return = pure   Mit mx >>= f =-    Mit \k ->-      mx (\a -> unMit (f a) k)+    Mit \r k ->+      mx r (\a -> unMit (f a) r k)  instance MonadIO (Mit r x) where   liftIO = io -unMit :: Mit r x a -> (a -> r -> IO x) -> r -> IO x-unMit (Mit k) = k+unMit :: Mit r x a -> r -> (a -> IO x) -> IO x+unMit (Mit k) =+  k  runMit :: r -> Mit r a a -> IO a runMit r m =-  unMit m (\x _ -> pure x) r+  unMit m r pure +return :: x -> Mit r x a+return x =+  Mit \_ _ -> pure x+ io :: IO a -> Mit r x a io m =-  Mit \k r -> do+  Mit \_ k -> do     x <- m-    k x r+    k x  getEnv :: Mit r x r getEnv =-  Mit \k r -> k r r+  Mit \r k -> k r -throw :: x -> Mit r x a-throw x =-  Mit \_ _ -> pure x+withEnv :: (r -> s) -> Mit s x a -> Mit r x a+withEnv f m =+  Mit \r k -> unMit m (f r) k -acquire :: (forall b. (a -> IO b) -> IO b) -> Mit r x a-acquire f =-  Mit \k r ->-    f \a -> k a r+type Goto r x a =+  forall xx void. Label (X x a) xx => a -> Mit r xx void -acquire_ :: (forall b. IO b -> IO b) -> Mit r x ()-acquire_ f =-  acquire \k -> f (k ())+label :: forall r x a. (Goto r x a -> Mit r (X x a) a) -> Mit r x a+label f =+  Mit \r k -> do+    unX k (unMit (f \a -> return (bury @(X x a) (XR a))) r (pure . XR)) -block :: Mit r a a -> Mit r x a-block m =-  Mit \k r -> do-    a <- runMit r m-    k a r+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)) -ublock :: Mit r a a -> Mit r x (Either SomeException a)-ublock m =-  Mit \k r -> do-    a <- try (runMit r m)-    k a r+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...++data X a b+  = XL a+  | XR b++unX :: (a -> IO b) -> IO (X b a) -> IO b+unX k mx =+  mx >>= \case+    XL b -> pure b+    XR a -> k a++class Label a b where+  bury :: a -> b+  default bury :: a ~ b => a -> b+  bury = id++-- FIXME I don't really think this is correct...+instance {-# INCOHERENT #-} Label (X a b) (X a b)++instance Label (X a b) (X c d) => Label (X a b) (X (X c d) e) where+  bury = XL . bury
src/Mit/Prelude.hs view
@@ -6,13 +6,14 @@  import Control.Applicative as X ((<|>)) import Control.Category as X hiding (id, (.))+import Control.Concurrent.STM as X (atomically) import Control.Exception as X hiding (handle, throw)-import Control.Monad as X+import Control.Monad as X hiding (return) import Control.Monad.IO.Class as X (MonadIO (..))-import Control.Concurrent.STM as X (atomically) import Data.Char as X import Data.Foldable as X import Data.Function as X+import Data.Functor as X (($>)) import Data.IORef as X import Data.List.NonEmpty qualified as List1 import Data.Map as X (Map)@@ -23,11 +24,12 @@ import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.Traversable as X+import Data.Void as X (Void) import Data.Word as X (Word64) import GHC.Stack as X (HasCallStack) import Mit.Seq1 as X (Seq1) import Text.Read as X (readMaybe)-import Prelude as X hiding (head, id)+import Prelude as X hiding (head, id, return)  type List1 =   List1.NonEmpty
src/Mit/State.hs view
@@ -10,6 +10,7 @@ import Data.Text qualified as Text import Data.Text.Encoding.Base64 qualified as Text import Data.Text.IO qualified as Text+import Mit.Env (Env (..)) import Mit.Git import Mit.Monad import Mit.Prelude@@ -27,7 +28,7 @@ emptyMitState =   MitState {head = (), merging = Nothing, undos = []} -deleteMitState :: Text -> Mit Int x ()+deleteMitState :: Text -> Mit Env x () deleteMitState branch64 = do   mitfile <- getMitfile branch64   io (removeFile mitfile `catch` \(_ :: IOException) -> pure ())@@ -44,26 +45,33 @@   undos <- Text.stripPrefix "undos " undosLine >>= parseUndos   pure MitState {head, merging, undos} -readMitState :: Text -> Mit Int x (MitState ())-readMitState branch = do-  head <- gitHead-  mitfile <- getMitfile branch64-  io (try (Text.readFile mitfile)) >>= \case-    Left (_ :: IOException) -> pure emptyMitState-    Right contents -> do-      let maybeState = do-            state <- parseMitState contents-            guard (head == state.head)-            pure state+readMitState :: Text -> Mit Env x (MitState ())+readMitState branch =+  label \return -> do+    head <-+      gitMaybeHead >>= \case+        Nothing -> return emptyMitState+        Just head -> pure head+    mitfile <- getMitfile branch64+    contents <-+      io (try (Text.readFile mitfile)) >>= \case+        Left (_ :: IOException) -> return emptyMitState+        Right contents -> pure contents+    let maybeState = do+          state <- parseMitState contents+          guard (head == state.head)+          pure state+    state <-       case maybeState of         Nothing -> do           deleteMitState branch64-          pure emptyMitState-        Just state -> pure (state {head = ()} :: MitState ())+          return emptyMitState+        Just state -> pure state+    pure (state {head = ()} :: MitState ())   where     branch64 = Text.encodeBase64 branch -writeMitState :: Text -> MitState () -> Mit Int x ()+writeMitState :: Text -> MitState () -> Mit Env x () writeMitState branch state = do   head <- gitHead   let contents :: Text@@ -76,7 +84,7 @@   mitfile <- getMitfile (Text.encodeBase64 branch)   io (Text.writeFile mitfile contents `catch` \(_ :: IOException) -> pure ()) -getMitfile :: Text -> Mit Int x FilePath+getMitfile :: Text -> Mit Env x FilePath getMitfile branch64 = do-  gitdir <- gitRevParseAbsoluteGitDir-  pure (Text.unpack (gitdir <> "/.mit-" <> branch64))+  env <- getEnv+  pure (Text.unpack (env.gitdir <> "/.mit-" <> branch64))
src/Mit/Undo.hs view
@@ -9,6 +9,7 @@ where  import Data.Text qualified as Text+import Mit.Env (Env) import Mit.Git import Mit.Monad import Mit.Prelude@@ -42,7 +43,7 @@           error (show text)         ] -applyUndo :: Undo -> Mit Int x ()+applyUndo :: Undo -> Mit Env x () applyUndo = \case   Apply commit -> do     git_ ["stash", "apply", "--quiet", commit]