mit-3qvpPyAi6mH 8 → 9
raw patch · 10 files changed
+481/−375 lines, 10 filesdep +stmdep ~basedep ~containersdep ~directory
Dependencies added: stm
Dependency ranges changed: base, containers, directory, ki, parsec, process
Files
- mit-3qvpPyAi6mH.cabal +10/−8
- src/Mit.hs +258/−228
- src/Mit/Config.hs +0/−17
- src/Mit/Directory.hs +10/−8
- src/Mit/Git.hs +92/−86
- src/Mit/GitCommand.hs +18/−16
- src/Mit/Monad.hs +73/−0
- src/Mit/Prelude.hs +3/−1
- src/Mit/State.hs +15/−10
- src/Mit/Undo.hs +2/−1
mit-3qvpPyAi6mH.cabal view
@@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX-version: 8+version: 9 description: A git wrapper with a streamlined UX.@@ -49,6 +49,7 @@ OverloadedRecordDot OverloadedStrings PatternSynonyms+ RankNTypes ScopedTypeVariables TupleSections TypeApplications@@ -67,24 +68,25 @@ library import: component build-depends:- base == 4.16.1.0,+ base == 4.16.1.0 || == 4.16.2.0, base64 == 0.4.2.4,- containers == 0.6.4.1,- directory == 1.3.6.2,- ki == 0.2.0.1,+ containers == 0.6.5.1,+ directory == 1.3.7.0,+ ki == 1.0.0, optparse-applicative == 0.17.0.0,- parsec == 3.1.15.0,- process == 1.6.13.2,+ parsec == 3.1.15.1,+ process == 1.6.14.0,+ stm == 2.5.0.2, text == 1.2.5.0, text-ansi == 0.1.1, unix == 2.7.2.2, exposed-modules: Mit Mit.Builder- Mit.Config Mit.Directory Mit.Git Mit.GitCommand+ Mit.Monad Mit.Prelude Mit.Process Mit.Seq
src/Mit.hs view
@@ -4,17 +4,17 @@ where import Data.List.NonEmpty qualified as List1+import Data.Ord (clamp) import Data.Sequence qualified as Seq import Data.Text qualified as Text-import Data.Text.ANSI qualified as Text-import Data.Text.Builder.ANSI qualified as Text.Builder-import Data.Text.IO qualified as Text+import Data.Text.Builder.ANSI qualified as Text import Data.Text.Lazy.Builder qualified as Text (Builder) import Data.Text.Lazy.Builder qualified as Text.Builder import Mit.Builder qualified as Builder import Mit.Directory import Mit.Git import Mit.GitCommand qualified as Git+import Mit.Monad import Mit.Prelude import Mit.Seq1 qualified as Seq1 import Mit.Stanza@@ -22,7 +22,7 @@ import Mit.Undo import Options.Applicative qualified as Opt import Options.Applicative.Types qualified as Opt (Backtracking (Backtrack))-import System.Exit (ExitCode (..), exitFailure)+import System.Exit (exitFailure) -- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit -- ephemeral feeling@@ -42,8 +42,13 @@ -- TODO more specific "undo this change" wording main :: IO ()-main =- join (Opt.customExecParser parserPrefs parserInfo)+main = do+ (verbosity, action) <- Opt.customExecParser parserPrefs parserInfo+ runMit (clamp (0, 2) verbosity) ([] <$ action) >>= \case+ [] -> pure ()+ errs -> do+ putStanzas errs+ exitFailure where parserPrefs :: Opt.ParserPrefs parserPrefs =@@ -59,49 +64,60 @@ prefTabulateFill = 24 -- grabbed this from optparse-applicative } - parserInfo :: Opt.ParserInfo (IO ())+ parserInfo :: Opt.ParserInfo (Int, Mit Int [Stanza] ()) parserInfo = Opt.info parser $ Opt.progDesc "mit: a git wrapper with a streamlined UX" - parser :: Opt.Parser (IO ())+ parser :: Opt.Parser (Int, Mit Int [Stanza] ()) parser =- (Opt.hsubparser . fold)- [ Opt.command "branch" $- Opt.info- (mitBranch <$> Opt.strArgument (Opt.metavar "≪branch≫"))- (Opt.progDesc "Create a new branch in a new worktree."),- Opt.command "commit" $- Opt.info- (pure mitCommit)- (Opt.progDesc "Create a commit interactively."),- Opt.command "merge" $- Opt.info- (mitMerge <$> Opt.strArgument (Opt.metavar "≪branch≫"))- (Opt.progDesc "Merge the given branch into the current branch."),- Opt.command "sync" $- Opt.info- (pure mitSync)- (Opt.progDesc "Sync with the remote named `origin`."),- Opt.command "undo" $- Opt.info- (pure mitUndo)- (Opt.progDesc "Undo the last `mit` command (if possible).")- ]+ (,)+ <$> 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≫"))+ (Opt.progDesc "Create a new branch in a new worktree."),+ Opt.command "commit" $+ Opt.info+ (pure mitCommit)+ (Opt.progDesc "Create a commit interactively."),+ Opt.command "merge" $+ Opt.info+ (mitMerge <$> Opt.strArgument (Opt.metavar "≪branch≫"))+ (Opt.progDesc "Merge the given branch into the current branch."),+ Opt.command "sync" $+ Opt.info+ (pure mitSync)+ (Opt.progDesc "Sync with the remote named `origin`."),+ Opt.command "undo" $+ Opt.info+ (pure mitUndo)+ (Opt.progDesc "Undo the last `mit` command (if possible).")+ ] -dieIfBuggyGit :: IO ()+dieIfBuggyGit :: Mit Int [Stanza] () dieIfBuggyGit = do version <- gitVersion let validate (ver, err) = if version < ver then ((ver, err) :) else id case foldr validate [] validations of [] -> pure () errors ->- die $+ throw $ map- (\(ver, err) -> "Prior to " <> Text.bold "git" <> " version " <> showGitVersion ver <> ", " <> err)+ ( \(ver, err) ->+ Just+ ( Text.red+ ( "Prior to " <> Text.bold "git" <> " version "+ <> Text.Builder.fromText (showGitVersion ver)+ <> ", "+ <> err+ )+ )+ ) errors where- validations :: [(GitVersion, Text)]+ validations :: [(GitVersion, Text.Builder)] validations = [ ( GitVersion 2 29 0, Text.bold "git commit --patch"@@ -117,30 +133,31 @@ ) ] -dieIfMergeInProgress :: IO ()+dieIfMergeInProgress :: Mit Int [Stanza] () dieIfMergeInProgress =- whenM gitMergeInProgress (die [Text.bold "git merge" <> " in progress."])+ whenM gitMergeInProgress (throw [Just (Text.red (Text.bold "git merge" <> " in progress."))]) -dieIfNotInGitDir :: IO ()-dieIfNotInGitDir =- try (evaluate gitdir) >>= \case- Left (_ :: ExitCode) -> exitFailure+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 () -die :: [Text] -> IO a-die ss = do- Text.putStr (Text.red (Text.unlines ss))- exitFailure--mitBranch :: Text -> IO ()+mitBranch :: Text -> Mit Int [Stanza] () mitBranch branch = do dieIfNotInGitDir + worktreeDir <- do+ rootdir <- gitRevParseShowToplevel+ pure (Text.dropWhileEnd (/= '/') rootdir <> branch)+ gitBranchWorktreeDir branch >>= \case Nothing -> do- whenM (doesDirectoryExist worktreeDir) (die ["Directory " <> Text.bold worktreeDir <> " already exists."])+ whenM (doesDirectoryExist worktreeDir) do+ throw [Just (Text.red ("Directory " <> Text.bold (Text.Builder.fromText worktreeDir) <> " already exists."))] git_ ["worktree", "add", "--detach", worktreeDir]- withCurrentDirectory worktreeDir do+ block do+ cd worktreeDir whenNotM (Git.git (Git.Switch branch)) do gitBranch branch Git.git_ (Git.Switch branch)@@ -151,13 +168,20 @@ Git.git_ (Git.BranchSetUpstreamTo upstream) Just directory -> when (directory /= worktreeDir) do- die [Text.bold branch <> " is already checked out in " <> Text.bold directory <> "."]- where- worktreeDir :: Text- worktreeDir =- Text.dropWhileEnd (/= '/') rootdir <> branch+ throw+ [ Just+ ( Text.red+ ( Text.bold+ ( Text.Builder.fromText branch+ <> " is already checked out in "+ <> Text.bold (Text.Builder.fromText directory)+ )+ <> "."+ )+ )+ ] -mitCommit :: IO ()+mitCommit :: Mit Int [Stanza] () mitCommit = do dieIfNotInGitDir whenM gitExistUntrackedFiles dieIfBuggyGit@@ -166,10 +190,10 @@ False -> gitDiff >>= \case Differences -> mitCommit_- NoDifferences -> exitFailure+ NoDifferences -> throw [Just (Text.red "There's nothing to commit.")] True -> mitCommitMerge -mitCommit_ :: IO ()+mitCommit_ :: Mit Int [Stanza] () mitCommit_ = do context <- getContext let upstream = "origin/" <> context.branch@@ -178,11 +202,10 @@ existLocalCommits <- contextExistLocalCommits context when (existRemoteCommits && not existLocalCommits) do- putStanzas $+ throw [ notSynchronizedStanza context.branch upstream ".", runSyncStanza "Run" context.branch upstream ]- exitFailure committed <- gitCommit @@ -215,51 +238,52 @@ then pure [] else gitConflictsWith (fromJust context.upstreamHead) - putStanzas- [ isSynchronizedStanza2 context.branch push.what,- do- commits <- Seq1.fromSeq remoteCommits- syncStanza Sync {commits, success = False, source = upstream, target = context.branch},- do- commits <- Seq1.fromSeq push.commits- 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 List1.nonEmpty conflictsOnSync of- Nothing -> runSyncStanza "Run" context.branch upstream- Just conflictsOnSync1 ->- renderStanzas- [ conflictsStanza- ( "These files will be in conflict when you run "- <> Text.Builder.bold (Text.Builder.blue "mit sync")- <> ":"- )- conflictsOnSync1,- Just $- " Run "- <> Text.Builder.bold (Text.Builder.blue "mit sync")- <> ", resolve the conflicts, then run "- <> Text.Builder.bold (Text.Builder.blue "mit commit")- <> " to synchronize "- <> branchb context.branch- <> " with "- <> branchb upstream- <> "."- ]- 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.- --- -- In this case, the underlying state hasn't changed, so 'mit undo' will still work as if the 'mit commit' was- -- never run, we merely don't want to *say* "run 'mit undo' to undo" as feedback, because that sounds as if it- -- would undo the last command run, namely the 'mit commit' that was aborted.- if not (null state.undos) && committed then canUndoStanza else Nothing- ]+ io do+ putStanzas+ [ isSynchronizedStanza2 context.branch push.what,+ do+ commits <- Seq1.fromSeq remoteCommits+ syncStanza Sync {commits, success = False, source = upstream, target = context.branch},+ do+ commits <- Seq1.fromSeq push.commits+ 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 List1.nonEmpty conflictsOnSync of+ Nothing -> runSyncStanza "Run" context.branch upstream+ Just conflictsOnSync1 ->+ renderStanzas+ [ conflictsStanza+ ( "These files will be in conflict when you run "+ <> Text.bold (Text.blue "mit sync")+ <> ":"+ )+ conflictsOnSync1,+ Just $+ " Run "+ <> Text.bold (Text.blue "mit sync")+ <> ", resolve the conflicts, then run "+ <> Text.bold (Text.blue "mit commit")+ <> " to synchronize "+ <> branchb context.branch+ <> " with "+ <> branchb upstream+ <> "."+ ]+ 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.+ --+ -- In this case, the underlying state hasn't changed, so 'mit undo' will still work as if the 'mit commit' was+ -- never run, we merely don't want to *say* "run 'mit undo' to undo" as feedback, because that sounds as if it+ -- would undo the last command run, namely the 'mit commit' that was aborted.+ if not (null state.undos) && committed then canUndoStanza else Nothing+ ] -mitCommitMerge :: IO ()+mitCommitMerge :: Mit Int x () mitCommitMerge = do context <- getContext @@ -294,13 +318,14 @@ -- FIXME we just unstashed, now we're about to stash again :/ Nothing -> mitSyncWith stanza0 (Just [Reset context.snapshot.head, Apply stash]) Just conflicts1 ->- putStanzas- [ stanza0,- conflictsStanza "These files are in conflict:" conflicts1,- -- Fake like we didn't push due to merge conflicts just to print "resolve conflicts and commit"- whatNextStanza context.branch (PushNotAttempted MergeConflicts),- if null context.state.undos then Nothing else canUndoStanza- ]+ io do+ 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),+ if null context.state.undos then Nothing else canUndoStanza+ ] -- FIXME delete data PushResult@@ -314,7 +339,7 @@ | 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 -> IO ()+mitMerge :: Text -> Mit Int [Stanza] () mitMerge target = do dieIfNotInGitDir dieIfMergeInProgress@@ -328,10 +353,15 @@ mitSyncWith Nothing Nothing else mitMergeWith context target -mitMergeWith :: Context -> Text -> IO ()+mitMergeWith :: Context -> Text -> Mit Int [Stanza] () mitMergeWith 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 exitFailure)+ targetCommit <-+ gitRemoteBranchHead "origin" target+ & onNothingM+ ( gitBranchHead target+ & onNothingM (throw [Just (Text.red "No such branch.")])+ ) let upstream = "origin/" <> context.branch @@ -339,11 +369,10 @@ existLocalCommits <- contextExistLocalCommits context when (existRemoteCommits && not existLocalCommits) do- putStanzas $+ throw [ notSynchronizedStanza context.branch upstream ".", runSyncStanza "Run" context.branch upstream ]- exitFailure whenJust context.snapshot.stash \_stash -> Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD")@@ -357,7 +386,6 @@ Just stash -> gitApplyStash stash else pure [] - -- THIS IS NEW push <- performPush context.branch let state =@@ -385,61 +413,62 @@ then pure [] else gitConflictsWith (fromJust context.upstreamHead) - putStanzas- [ if null merge.conflicts- then synchronizedStanza context.branch target- else notSynchronizedStanza context.branch target ".",- do- commits1 <- Seq1.fromSeq merge.commits- syncStanza- Sync- { commits = commits1,- success = null merge.conflicts,- source = target,- target = context.branch- },- isSynchronizedStanza2 context.branch push.what,- do- commits <- Seq1.fromSeq remoteCommits- syncStanza Sync {commits, success = False, source = upstream, target = context.branch},- -- TODO show commits to remote- do- conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts- conflictsStanza "These files are in conflict:" conflicts1,- -- TODO audit this- case push.what of- NothingToPush2 -> Nothing- Pushed -> Nothing- PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream- -- FIXME hrm, but we might have merge conflicts and/or stash conflicts!- PushWouldBeRejected ->- case List1.nonEmpty conflictsOnSync of- Nothing -> runSyncStanza "Run" context.branch upstream- Just conflictsOnSync1 ->- renderStanzas- [ conflictsStanza- ( "These files will be in conflict when you run "- <> Text.Builder.bold (Text.Builder.blue "mit sync")- <> ":"- )- conflictsOnSync1,- Just $- " Run "- <> Text.Builder.bold (Text.Builder.blue "mit sync")- <> ", resolve the conflicts, then run "- <> Text.Builder.bold (Text.Builder.blue "mit commit")- <> " to synchronize "- <> branchb context.branch- <> " with "- <> branchb upstream- <> "."- ]- TriedToPush -> runSyncStanza "Run" context.branch upstream,- if not (null state.undos) then canUndoStanza else Nothing- ]+ io do+ putStanzas+ [ if null merge.conflicts+ then synchronizedStanza context.branch target+ else notSynchronizedStanza context.branch target ".",+ do+ commits1 <- Seq1.fromSeq merge.commits+ syncStanza+ Sync+ { commits = commits1,+ success = null merge.conflicts,+ source = target,+ target = context.branch+ },+ isSynchronizedStanza2 context.branch push.what,+ do+ commits <- Seq1.fromSeq remoteCommits+ syncStanza Sync {commits, success = False, source = upstream, target = context.branch},+ -- TODO show commits to remote+ do+ conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts+ conflictsStanza "These files are in conflict:" conflicts1,+ -- TODO audit this+ case push.what of+ NothingToPush2 -> Nothing+ Pushed -> Nothing+ PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream+ -- FIXME hrm, but we might have merge conflicts and/or stash conflicts!+ PushWouldBeRejected ->+ case List1.nonEmpty conflictsOnSync of+ Nothing -> runSyncStanza "Run" context.branch upstream+ Just conflictsOnSync1 ->+ renderStanzas+ [ conflictsStanza+ ( "These files will be in conflict when you run "+ <> Text.bold (Text.blue "mit sync")+ <> ":"+ )+ conflictsOnSync1,+ Just $+ " Run "+ <> Text.bold (Text.blue "mit sync")+ <> ", resolve the conflicts, then run "+ <> Text.bold (Text.blue "mit commit")+ <> " to synchronize "+ <> branchb context.branch+ <> " with "+ <> branchb upstream+ <> "."+ ]+ TriedToPush -> runSyncStanza "Run" context.branch upstream,+ 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 :: IO ()+mitSync :: Mit Int [Stanza] () mitSync = do dieIfNotInGitDir dieIfMergeInProgress@@ -466,7 +495,7 @@ -- -- 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] -> IO ()+mitSyncWith :: Stanza -> Maybe [Undo] -> Mit Int x () mitSyncWith stanza0 maybeUndos = do context <- getContext let upstream = "origin/" <> context.branch@@ -511,54 +540,55 @@ writeMitState context.branch state - putStanzas- [ stanza0,- isSynchronizedStanza2 context.branch push.what,- do- commits1 <- Seq1.fromSeq merge.commits- syncStanza- Sync- { commits = commits1,- success = null merge.conflicts,- source = upstream,- target = context.branch- },- do- commits <- Seq1.fromSeq push.commits- syncStanza- Sync- { commits,- success = pushPushed push,- source = context.branch,- target = upstream- },- do- conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts- conflictsStanza "These files are in conflict:" conflicts1,- case push.what of- NothingToPush2 -> Nothing- Pushed -> Nothing- PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream- PushWouldBeRejected ->- Just $- " Resolve the conflicts, then run "- <> Text.Builder.bold (Text.Builder.blue "mit commit")- <> " to synchronize "- <> branchb context.branch- <> " with "- <> branchb upstream- <> "."- TriedToPush -> runSyncStanza "Run" context.branch upstream,- if not (null state.undos) then canUndoStanza else Nothing- ]+ io do+ putStanzas+ [ stanza0,+ isSynchronizedStanza2 context.branch push.what,+ do+ commits1 <- Seq1.fromSeq merge.commits+ syncStanza+ Sync+ { commits = commits1,+ success = null merge.conflicts,+ source = upstream,+ target = context.branch+ },+ do+ commits <- Seq1.fromSeq push.commits+ syncStanza+ Sync+ { commits,+ success = pushPushed push,+ source = context.branch,+ target = upstream+ },+ do+ conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts+ conflictsStanza "These files are in conflict:" conflicts1,+ case push.what of+ NothingToPush2 -> Nothing+ Pushed -> Nothing+ PushWouldntReachRemote -> runSyncStanza "When you come online, run" context.branch upstream+ PushWouldBeRejected ->+ Just $+ " Resolve the conflicts, then run "+ <> Text.bold (Text.blue "mit commit")+ <> " to synchronize "+ <> branchb context.branch+ <> " with "+ <> branchb upstream+ <> "."+ TriedToPush -> runSyncStanza "Run" context.branch upstream,+ if not (null state.undos) then canUndoStanza else Nothing+ ] -- FIXME output what we just undid-mitUndo :: IO ()+mitUndo :: Mit Int [Stanza] () mitUndo = do dieIfNotInGitDir context <- getContext case List1.nonEmpty context.state.undos of- Nothing -> exitFailure+ Nothing -> throw [Just (Text.red "Nothing to undo.")] Just undos1 -> for_ undos1 applyUndo when (undosContainRevert context.state.undos) mitSync where@@ -578,7 +608,7 @@ canUndoStanza :: Stanza canUndoStanza =- Just (" Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change.")+ Just (" Run " <> Text.bold (Text.blue "mit undo") <> " to undo this change.") conflictsStanza :: Text.Builder -> List1 GitConflict -> Stanza conflictsStanza prefix conflicts =@@ -586,7 +616,7 @@ " " <> prefix <> Builder.newline- <> Builder.vcat ((\conflict -> " " <> Text.Builder.red (showGitConflict conflict)) <$> conflicts)+ <> Builder.vcat ((\conflict -> " " <> Text.red (showGitConflict conflict)) <$> conflicts) isSynchronizedStanza2 :: Text -> GitPushWhat -> Stanza isSynchronizedStanza2 branch = \case@@ -594,13 +624,13 @@ 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.Builder.bold "git push" <> " failed.")+ TriedToPush -> notSynchronizedStanza branch upstream (" because " <> Text.bold "git push" <> " failed.") where upstream = "origin/" <> branch notSynchronizedStanza :: Text -> Text -> Text.Builder -> Stanza notSynchronizedStanza branch other suffix =- Just (" " <> Text.Builder.red (branchb branch <> " is not synchronized with " <> branchb other <> suffix))+ Just (" " <> Text.red (branchb branch <> " is not synchronized with " <> branchb other <> suffix)) runSyncStanza :: Text.Builder -> Text -> Text -> Stanza runSyncStanza prefix branch upstream =@@ -608,7 +638,7 @@ " " <> prefix <> " "- <> Text.Builder.bold (Text.Builder.blue "mit sync")+ <> Text.bold (Text.blue "mit sync") <> " to synchronize " <> branchb branch <> " with "@@ -618,7 +648,7 @@ syncStanza :: Sync -> Stanza syncStanza sync = Just $- Text.Builder.italic+ Text.italic (colorize (" " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)) <> "\n" <> (Builder.vcat ((\commit -> " " <> prettyGitCommitInfo commit) <$> commits'))@@ -626,7 +656,7 @@ where colorize :: Text.Builder -> Text.Builder colorize =- if sync.success then Text.Builder.green else Text.Builder.red+ if sync.success then Text.green else Text.red (commits', more) = case Seq1.length sync.commits > 10 of False -> (Seq1.toSeq sync.commits, False)@@ -634,7 +664,7 @@ synchronizedStanza :: Text -> Text -> Stanza synchronizedStanza branch other =- Just (" " <> Text.Builder.green (branchb branch <> " is synchronized with " <> branchb other <> "."))+ Just (" " <> Text.green (branchb branch <> " is synchronized with " <> branchb other <> ".")) -- FIXME remove whatNextStanza :: Text -> PushResult -> Stanza@@ -670,13 +700,13 @@ PushNotAttempted Offline -> runSyncStanza "When you come online, run" branch upstream PushNotAttempted UnseenCommits -> runSyncStanza "Examine the repository, then run" branch upstream where- commit = Text.Builder.bold (Text.Builder.blue "mit commit")- sync = Text.Builder.bold (Text.Builder.blue "mit sync")+ commit = Text.bold (Text.blue "mit commit")+ sync = Text.bold (Text.blue "mit sync") upstream = "origin/" <> branch branchb :: Text -> Text.Builder branchb =- Text.Builder.italic . Text.Builder.fromText+ Text.italic . Text.Builder.fromText ------------------------------------------------------------------------------------------------------------------------ -- Context@@ -688,7 +718,7 @@ upstreamHead :: Maybe Text } -getContext :: IO Context+getContext :: Mit Int x Context getContext = do gitFetch_ "origin" branch <- Git.git Git.BranchShowCurrent@@ -697,13 +727,13 @@ snapshot <- performSnapshot pure Context {branch, snapshot, state, upstreamHead} -contextExistLocalCommits :: Context -> IO Bool+contextExistLocalCommits :: Context -> Mit Int x Bool contextExistLocalCommits context = case context.upstreamHead of Nothing -> pure True Just upstreamHead -> gitExistCommitsBetween upstreamHead context.snapshot.head -contextExistRemoteCommits :: Context -> IO Bool+contextExistRemoteCommits :: Context -> Mit Int x Bool contextExistRemoteCommits context = case context.upstreamHead of Nothing -> pure False@@ -727,7 +757,7 @@ -- conflicts. -- -- Precondition: the working directory is clean. TODO take unused GitStash as argument?-performMerge :: Text -> Text -> IO GitMerge+performMerge :: Text -> Text -> Mit Int x GitMerge performMerge message commitish = do head <- gitHead commits <- gitCommitsBetween (Just head) commitish@@ -769,7 +799,7 @@ TriedToPush -> False -- TODO get context-performPush :: Text -> IO GitPush+performPush :: Text -> Mit Int x GitPush performPush branch = do fetched <- gitFetch "origin" head <- gitHead@@ -806,7 +836,7 @@ stash :: Maybe Text } -performSnapshot :: IO GitSnapshot+performSnapshot :: Mit Int x GitSnapshot performSnapshot = do head <- gitHead stash <-
− src/Mit/Config.hs
@@ -1,17 +0,0 @@-module Mit.Config- ( verbose,- )-where--import Mit.Prelude-import System.Environment (lookupEnv)-import System.IO.Unsafe (unsafePerformIO)--verbose :: Int-verbose =- unsafePerformIO do- lookupEnv "MIT_VERBOSE" <&> \case- Just "1" -> 1- Just "2" -> 2- _ -> 0-{-# NOINLINE verbose #-}
src/Mit/Directory.hs view
@@ -1,17 +1,19 @@ module Mit.Directory- ( doesDirectoryExist,- withCurrentDirectory,+ ( cd,+ doesDirectoryExist, ) where import Data.Text qualified as Text+import Mit.Monad import Mit.Prelude import System.Directory qualified as Directory -doesDirectoryExist :: Text -> IO Bool-doesDirectoryExist =- Directory.doesDirectoryExist . Text.unpack+cd :: Text -> Mit r x ()+cd dir =+ acquire_ (Directory.withCurrentDirectory (Text.unpack dir)) -withCurrentDirectory :: Text -> IO a -> IO a-withCurrentDirectory dir =- Directory.withCurrentDirectory (Text.unpack dir)+-- | Change directories (delimited by 'block').+doesDirectoryExist :: MonadIO m => Text -> m Bool+doesDirectoryExist =+ liftIO . Directory.doesDirectoryExist . Text.unpack
src/Mit/Git.hs view
@@ -11,10 +11,11 @@ import Data.Text.Lazy.Builder qualified as Text.Builder import Ki qualified import Mit.Builder qualified as Builder-import Mit.Config (verbose) import Mit.GitCommand qualified as Git+import Mit.Monad import Mit.Prelude import Mit.Process+import Mit.Stanza import System.Directory (doesFileExist) import System.Environment (lookupEnv) import System.Exit (ExitCode (..))@@ -27,17 +28,6 @@ import System.Process.Internals import Text.Parsec qualified as Parsec -gitdir :: Text-gitdir =- unsafePerformIO (git ["rev-parse", "--absolute-git-dir"])-{-# NOINLINE gitdir #-}---- | The root of this git worktree.-rootdir :: Text-rootdir =- unsafePerformIO (git ["rev-parse", "--show-toplevel"])-{-# NOINLINE rootdir #-}- data DiffResult = Differences | NoDifferences@@ -145,7 +135,7 @@ Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z) -- | Apply stash, return conflicts.-gitApplyStash :: Text -> IO [GitConflict]+gitApplyStash :: Text -> Mit Int x [GitConflict] gitApplyStash stash = do conflicts <- Git.git (Git.StashApply Git.FlagQuiet stash) >>= \case@@ -156,42 +146,42 @@ -- | Create a branch. -- FIXME inline this-gitBranch :: Text -> IO ()+gitBranch :: Text -> Mit Int x () gitBranch branch = Git.git (Git.Branch Git.FlagNoTrack branch) -- | Does the given local branch (refs/heads/...) exist?-gitBranchExists :: Text -> IO Bool+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 -> IO (Maybe Text)+gitBranchHead :: Text -> Mit Int 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 -> IO (Maybe Text)+gitBranchWorktreeDir :: Text -> Mit Int 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 :: IO Bool+gitCommit :: Mit Int x Bool gitCommit =- queryTerminal 0 >>= \case+ io (queryTerminal 0) >>= \case False -> do- message <- lookupEnv "MIT_COMMIT_MESSAGE"+ message <- io (lookupEnv "MIT_COMMIT_MESSAGE") git ["commit", "--all", "--message", maybe "" Text.pack message] True -> git2 ["commit", "--patch", "--quiet"] <&> \case ExitFailure _ -> False ExitSuccess -> True -gitCommitsBetween :: Maybe Text -> Text -> IO (Seq GitCommitInfo)+gitCommitsBetween :: Maybe Text -> Text -> Mit Int x (Seq GitCommitInfo) gitCommitsBetween commit1 commit2 = if commit1 == Just commit2 then pure Seq.empty@@ -214,14 +204,14 @@ _ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs xs -> xs -gitConflicts :: IO [GitConflict]+gitConflicts :: Mit Int 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 -> IO [GitConflict]+gitConflictsWith :: Text -> Mit Int x [GitConflict] gitConflictsWith commit = do maybeStash <- gitStash conflicts <-@@ -233,44 +223,44 @@ pure conflicts -- | Precondition: there are changes to stash-gitCreateStash :: IO Text+gitCreateStash :: Mit Int 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 -> IO Text+gitDefaultBranch :: Text -> Mit Int 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 :: IO DiffResult+gitDiff :: Mit Int x DiffResult gitDiff = do gitUnstageChanges Git.git (Git.Diff Git.FlagQuiet) <&> \case False -> Differences True -> NoDifferences -gitExistCommitsBetween :: Text -> Text -> IO Bool+gitExistCommitsBetween :: Text -> Text -> Mit Int 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 :: IO Bool+gitExistUntrackedFiles :: Mit Int x Bool gitExistUntrackedFiles = not . null <$> gitListUntrackedFiles -gitFetch :: Text -> IO Bool+gitFetch :: Text -> Mit Int x Bool gitFetch remote = do- fetched <- readIORef fetchedRef+ fetched <- io (readIORef fetchedRef) case Map.lookup remote fetched of Nothing -> do success <- Git.git (Git.Fetch remote)- writeIORef fetchedRef (Map.insert remote success fetched)+ io (writeIORef fetchedRef (Map.insert remote success fetched)) pure success Just success -> pure success @@ -280,44 +270,54 @@ unsafePerformIO (newIORef mempty) {-# NOINLINE fetchedRef #-} -gitFetch_ :: Text -> IO ()+gitFetch_ :: Text -> Mit Int x () gitFetch_ = void . gitFetch -gitHead :: IO Text+gitHead :: Mit Int x Text gitHead = Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify "HEAD") -gitIsMergeCommit :: Text -> IO Bool+gitIsMergeCommit :: Text -> Mit Int x Bool gitIsMergeCommit commit = Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify (commit <> "^2")) -- | List all untracked files.-gitListUntrackedFiles :: IO [Text]+gitListUntrackedFiles :: Mit Int x [Text] gitListUntrackedFiles = git ["ls-files", "--exclude-standard", "--other"] -gitMergeInProgress :: IO Bool-gitMergeInProgress =- doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD"))+gitMergeInProgress :: Mit Int x Bool+gitMergeInProgress = do+ gitdir <- gitRevParseAbsoluteGitDir+ io (doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD"))) -gitPush :: Text -> IO Bool+gitPush :: Text -> Mit Int x Bool gitPush branch = git ["push", "--set-upstream", "origin", "--quiet", branch <> ":" <> branch] -- | Does the given remote branch (refs/remotes/...) exist?-gitRemoteBranchExists :: Text -> Text -> IO Bool+gitRemoteBranchExists :: Text -> Text -> Mit Int 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 -> IO (Maybe Text)+gitRemoteBranchHead :: Text -> Text -> Mit Int 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 -gitShow :: Text -> IO GitCommitInfo+gitRevParseAbsoluteGitDir :: Mit Int x Text+gitRevParseAbsoluteGitDir =+ git ["rev-parse", "--absolute-git-dir"]++-- | The root of this git worktree.+gitRevParseShowToplevel :: Mit Int x Text+gitRevParseShowToplevel =+ git ["rev-parse", "--show-toplevel"]++gitShow :: Text -> Mit Int x GitCommitInfo gitShow commit = parseGitCommitInfo <$> git@@ -329,7 +329,7 @@ ] -- | Stash uncommitted changes (if any).-gitStash :: IO (Maybe Text)+gitStash :: Mit Int x (Maybe Text) gitStash = do gitDiff >>= \case Differences -> do@@ -339,16 +339,16 @@ pure (Just stash) NoDifferences -> pure Nothing -gitUnstageChanges :: IO ()+gitUnstageChanges :: Mit Int x () gitUnstageChanges = do Git.git_ (Git.ResetPaths Git.FlagQuiet ["."]) untrackedFiles <- gitListUntrackedFiles unless (null untrackedFiles) (Git.git_ (Git.Add Git.FlagIntentToAdd untrackedFiles)) -gitVersion :: IO GitVersion+gitVersion :: Mit Int [Stanza] GitVersion gitVersion = do v0 <- git ["--version"]- fromMaybe (throwIO (userError ("Could not parse git version from: " <> Text.unpack v0))) do+ fromMaybe (throw [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 +365,7 @@ -- /dir/one 0efd393c35 [oingo] -> ("/dir/one", "0efd393c35", Just "oingo") -- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing)-gitWorktreeList :: IO [GitWorktree]+gitWorktreeList :: Mit Int x [GitWorktree] gitWorktreeList = do git ["worktree", "list"] <&> map \line -> case Parsec.parse parser "" line of@@ -404,7 +404,7 @@ url' <- Text.stripSuffix ".git" url pure (url, Text.takeWhileEnd (/= '/') url') -git :: ProcessOutput a => [Text] -> IO a+git :: ProcessOutput a => [Text] -> Mit Int x a git args = do let spec :: CreateProcess spec =@@ -426,15 +426,16 @@ detach_console = False, use_process_jobs = False }- bracket (createProcess spec) cleanup \(_maybeStdin, maybeStdout, maybeStderr, processHandle) ->- Ki.scoped \scope -> do- stdoutThread <- Ki.fork scope (drainTextHandle (fromJust maybeStdout))- stderrThread <- Ki.fork scope (drainTextHandle (fromJust maybeStderr))- exitCode <- waitForProcess processHandle- stdoutLines <- Ki.await stdoutThread- stderrLines <- Ki.await stderrThread- debugPrintGit args stdoutLines stderrLines exitCode- fromProcessOutput stdoutLines stderrLines exitCode+ 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) where cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () cleanup (maybeStdin, maybeStdout, maybeStderr, process) =@@ -455,44 +456,49 @@ signalProcessGroup sigTERM pgid waitForProcess process -git_ :: [Text] -> IO ()+git_ :: [Text] -> Mit Int x () git_ = git -- Yucky interactive/inherity variant (so 'git commit' can open an editor).-git2 :: [Text] -> IO ExitCode+--+-- FIXME bracket+git2 :: [Text] -> Mit Int x ExitCode git2 args = do- (Nothing, Nothing, Just stderrHandle, processHandle) <-- createProcess- CreateProcess- { child_group = Nothing,- child_user = Nothing,- close_fds = True,- cmdspec = RawCommand "git" (map Text.unpack args),- create_group = False,- cwd = Nothing,- delegate_ctlc = True,- env = Nothing,- new_session = False,- std_err = CreatePipe,- std_in = Inherit,- std_out = Inherit,- -- windows-only- create_new_console = False,- detach_console = False,- use_process_jobs = False- }+ (_, _, stderrHandle, processHandle) <-+ io do+ createProcess+ CreateProcess+ { child_group = Nothing,+ child_user = Nothing,+ close_fds = True,+ cmdspec = RawCommand "git" (map Text.unpack args),+ create_group = False,+ cwd = Nothing,+ delegate_ctlc = True,+ env = Nothing,+ new_session = False,+ std_err = CreatePipe,+ std_in = Inherit,+ std_out = Inherit,+ -- windows-only+ create_new_console = False,+ detach_console = False,+ use_process_jobs = False+ } exitCode <-- waitForProcess processHandle `catch` \case- UserInterrupt -> pure (ExitFailure (-130))- exception -> throwIO exception- stderrLines <- drainTextHandle stderrHandle+ io do+ waitForProcess processHandle `catch` \case+ UserInterrupt -> pure (ExitFailure (-130))+ exception -> throwIO exception+ stderrLines <- io (drainTextHandle (fromJust stderrHandle)) debugPrintGit args Seq.empty stderrLines exitCode pure exitCode -debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()-debugPrintGit args stdoutLines stderrLines exitCode =- case verbose of+debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Int x ()+debugPrintGit args stdoutLines stderrLines exitCode = do+ verbose <- getEnv+ io case verbose of 1 -> Builder.putln (Text.Builder.brightBlack v1) 2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2)) _ -> pure ()
src/Mit/GitCommand.hs view
@@ -24,7 +24,7 @@ import Data.Text.Lazy.Builder qualified as Text.Builder import Ki qualified import Mit.Builder qualified as Builder-import Mit.Config (verbose)+import Mit.Monad import Mit.Prelude import Mit.Process import System.Exit (ExitCode (..))@@ -168,15 +168,15 @@ ------------------------------------------------------------------------------------------------------------------------ -- Git process stuff -git :: ProcessOutput a => Command -> IO a+git :: ProcessOutput a => Command -> Mit Int x a git = runGit . renderCommand -git_ :: Command -> IO ()+git_ :: Command -> Mit Int x () git_ = git -runGit :: ProcessOutput a => [Text] -> IO a+runGit :: ProcessOutput a => [Text] -> Mit Int x a runGit args = do let spec :: CreateProcess spec =@@ -198,15 +198,16 @@ detach_console = False, use_process_jobs = False }- bracket (createProcess spec) cleanup \(_maybeStdin, maybeStdout, maybeStderr, processHandle) ->- Ki.scoped \scope -> do- stdoutThread <- Ki.fork scope (drainTextHandle (fromJust maybeStdout))- stderrThread <- Ki.fork scope (drainTextHandle (fromJust maybeStderr))- exitCode <- waitForProcess processHandle- stdoutLines <- Ki.await stdoutThread- stderrLines <- Ki.await stderrThread- debugPrintGit args stdoutLines stderrLines exitCode- fromProcessOutput stdoutLines stderrLines exitCode+ 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) where cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () cleanup (maybeStdin, maybeStdout, maybeStderr, process) =@@ -227,9 +228,10 @@ signalProcessGroup sigTERM pgid waitForProcess process -debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()-debugPrintGit args stdoutLines stderrLines exitCode =- case verbose of+debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Int x ()+debugPrintGit args stdoutLines stderrLines exitCode = do+ verbose <- getEnv+ io case verbose of 1 -> Builder.putln (Text.Builder.brightBlack v1) 2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2)) _ -> pure ()
+ src/Mit/Monad.hs view
@@ -0,0 +1,73 @@+module Mit.Monad+ ( Mit,+ runMit,+ io,+ getEnv,+ throw,+ acquire,+ acquire_,+ block,+ ublock,+ )+where++import Mit.Prelude++newtype Mit r x a+ = Mit ((a -> r -> IO x) -> r -> IO x)+ deriving stock (Functor)++instance Applicative (Mit r x) where+ pure x = Mit \k r -> k x r+ (<*>) = ap++instance Monad (Mit r x) where+ return = pure+ Mit mx >>= f =+ Mit \k ->+ mx (\a -> unMit (f a) 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++runMit :: r -> Mit r a a -> IO a+runMit r m =+ unMit m (\x _ -> pure x) r++io :: IO a -> Mit r x a+io m =+ Mit \k r -> do+ x <- m+ k x r++getEnv :: Mit r x r+getEnv =+ Mit \k r -> k r r++throw :: x -> Mit r x a+throw x =+ Mit \_ _ -> pure x++acquire :: (forall b. (a -> IO b) -> IO b) -> Mit r x a+acquire f =+ Mit \k r ->+ f \a -> k a r++acquire_ :: (forall b. IO b -> IO b) -> Mit r x ()+acquire_ f =+ acquire \k -> f (k ())++block :: Mit r a a -> Mit r x a+block m =+ Mit \k r -> do+ a <- runMit r m+ k a r++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
src/Mit/Prelude.hs view
@@ -6,8 +6,10 @@ import Control.Applicative as X ((<|>)) import Control.Category as X hiding (id, (.))-import Control.Exception as X hiding (handle)+import Control.Exception as X hiding (handle, throw) import Control.Monad as X+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
src/Mit/State.hs view
@@ -11,6 +11,7 @@ import Data.Text.Encoding.Base64 qualified as Text import Data.Text.IO qualified as Text import Mit.Git+import Mit.Monad import Mit.Prelude import Mit.Undo import System.Directory (removeFile)@@ -26,9 +27,10 @@ emptyMitState = MitState {head = (), merging = Nothing, undos = []} -deleteMitState :: Text -> IO ()-deleteMitState branch64 =- removeFile (mitfile branch64) `catch` \(_ :: IOException) -> pure ()+deleteMitState :: Text -> Mit Int x ()+deleteMitState branch64 = do+ mitfile <- getMitfile branch64+ io (removeFile mitfile `catch` \(_ :: IOException) -> pure ()) parseMitState :: Text -> Maybe (MitState Text) parseMitState contents = do@@ -42,10 +44,11 @@ undos <- Text.stripPrefix "undos " undosLine >>= parseUndos pure MitState {head, merging, undos} -readMitState :: Text -> IO (MitState ())+readMitState :: Text -> Mit Int x (MitState ()) readMitState branch = do head <- gitHead- try (Text.readFile (mitfile branch64)) >>= \case+ mitfile <- getMitfile branch64+ io (try (Text.readFile mitfile)) >>= \case Left (_ :: IOException) -> pure emptyMitState Right contents -> do let maybeState = do@@ -60,7 +63,7 @@ where branch64 = Text.encodeBase64 branch -writeMitState :: Text -> MitState () -> IO ()+writeMitState :: Text -> MitState () -> Mit Int x () writeMitState branch state = do head <- gitHead let contents :: Text@@ -70,8 +73,10 @@ "merging " <> fromMaybe Text.empty state.merging, "undos " <> showUndos state.undos ]- Text.writeFile (mitfile (Text.encodeBase64 branch)) contents `catch` \(_ :: IOException) -> pure ()+ mitfile <- getMitfile (Text.encodeBase64 branch)+ io (Text.writeFile mitfile contents `catch` \(_ :: IOException) -> pure ()) -mitfile :: Text -> FilePath-mitfile branch64 =- Text.unpack (gitdir <> "/.mit-" <> branch64)+getMitfile :: Text -> Mit Int x FilePath+getMitfile branch64 = do+ gitdir <- gitRevParseAbsoluteGitDir+ pure (Text.unpack (gitdir <> "/.mit-" <> branch64))
src/Mit/Undo.hs view
@@ -10,6 +10,7 @@ import Data.Text qualified as Text import Mit.Git+import Mit.Monad import Mit.Prelude data Undo@@ -41,7 +42,7 @@ error (show text) ] -applyUndo :: Undo -> IO ()+applyUndo :: Undo -> Mit Int x () applyUndo = \case Apply commit -> do git_ ["stash", "apply", "--quiet", commit]