mit-3qvpPyAi6mH 4 → 5
raw patch · 4 files changed
+110/−72 lines, 4 filesdep ~basedep ~base64dep ~clock
Dependency ranges changed: base, base64, clock, containers, directory, ki, process, record-dot-preprocessor, record-hasfield, text, text-ansi, unix
Files
- mit-3qvpPyAi6mH.cabal +13/−13
- src/Mit.hs +29/−22
- src/Mit/Git.hs +53/−37
- src/Mit/Process.hs +15/−0
mit-3qvpPyAi6mH.cabal view
@@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX-version: 4+version: 5 description: A git wrapper with a streamlined UX.@@ -23,18 +23,18 @@ common component build-depends:- base < 5,- base64,- containers,- clock,- directory,- ki,- process,- record-dot-preprocessor,- record-hasfield,- text,- text-ansi,- unix,+ base == 4.14.3.0,+ base64 == 0.4.2.3,+ containers == 0.6.5.1,+ clock == 0.8.2,+ directory == 1.3.6.0,+ ki == 0.2.0.1,+ process == 1.6.13.2,+ record-dot-preprocessor == 0.2.13,+ record-hasfield == 1.0,+ text == 1.2.5.0,+ text-ansi == 0.1.1,+ unix == 2.7.2.2, default-extensions: BlockArguments DataKinds
src/Mit.hs view
@@ -7,8 +7,12 @@ import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.ANSI as Text+import qualified Data.Text.Builder.ANSI as Text.Builder import qualified Data.Text.Encoding.Base64 as Text import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Text.Lazy.Builder as Text (Builder)+import qualified Data.Text.Lazy.Builder as Text.Builder import Mit.Git import Mit.Prelude import qualified Mit.Seq1 as Seq1@@ -103,7 +107,7 @@ Nothing -> doesDirectoryExist (Text.unpack worktreeDir) >>= \case False -> do- git_ ["worktree", "add", "--detach", worktreeDir]+ gitl_ ["worktree", "add", "--detach", worktreeDir] withCurrentDirectory (Text.unpack worktreeDir) do gitBranchExists branch >>= \case False -> do@@ -112,8 +116,8 @@ gitFetch_ "origin" whenM (gitRemoteBranchExists "origin" branch) do let upstream = "origin/" <> branch- git_ ["reset", "--hard", upstream]- git_ ["branch", "--set-upstream-to", upstream]+ gitl_ ["reset", "--hard", upstream]+ gitl_ ["branch", "--set-upstream-to", upstream] True -> gitSwitch branch True -> die ["Directory " <> Text.bold worktreeDir <> " already exists."] Just directory ->@@ -148,9 +152,8 @@ let wouldFork = existRemoteCommits && not existLocalCommits let shouldWarnAboutFork =- case wouldFork of- False -> pure False- True -> do+ if wouldFork+ then do let theyRanMitCommitRecently = case state0.ranCommitAt of Nothing -> pure False@@ -158,6 +161,7 @@ t1 <- Clock.toNanoSecs <$> Clock.getTime Clock.Realtime pure ((t1 - t0) < 10_000_000_000) not <$> theyRanMitCommitRecently+ else pure False -- Bail out early if we should warn that this commit would fork history whenM shouldWarnAboutFork do@@ -238,10 +242,10 @@ state0 <- readMitState branch64 case state0.merging of- Nothing -> git_ ["commit", "--all", "--no-edit"]+ Nothing -> gitl_ ["commit", "--all", "--no-edit"] Just merging -> let message = fold ["⅄ ", if merging == branch then "" else merging <> " → ", branch]- in git_ ["commit", "--all", "--message", message]+ in gitl_ ["commit", "--all", "--message", message] case listToMaybe [commit | Apply commit <- state0.undos] of Nothing -> mitSyncWith (Just [Reset head]) Just stash ->@@ -355,7 +359,7 @@ maybeStash <- gitStash let undos = Reset head : maybeToList (Apply <$> maybeStash) result <-- git ["merge", "--ff", "--no-commit", target] >>= \case+ gitl ["merge", "--ff", "--no-commit", target] >>= \case False -> do conflicts <- gitConflicts -- error: The following untracked working tree files would be overwritten by merge:@@ -379,7 +383,7 @@ -- Aborting pure (MergeResult'MergeConflicts (List1.fromList conflicts)) True -> do- whenM gitMergeInProgress (git_ ["commit", "--message", message])+ whenM gitMergeInProgress (gitl_ ["commit", "--message", message]) maybeConflicts <- for maybeStash gitApplyStash pure (MergeResult'StashConflicts (fromMaybe [] maybeConflicts)) pure (Just MergeStatus {commits, result, undos})@@ -539,36 +543,39 @@ putSummary :: Summary -> IO () putSummary summary = let output = concatMap syncLines summary.syncs ++ conflictsLines ++ undoLines- in if null output then pure () else putLines ("" : output)+ in if null output then pure () else putLines (map (Text.Lazy.toStrict . Text.Builder.toLazyText) ("" : output)) where- conflictsLines :: [Text]+ conflictsLines :: [Text.Builder] conflictsLines = if null summary.conflicts then [] else " The following files have conflicts." :- map ((" " <>) . Text.red . showGitConflict) summary.conflicts ++ [""]- syncLines :: Sync -> [Text]+ map ((" " <>) . Text.Builder.red . showGitConflict) summary.conflicts ++ [""]+ syncLines :: Sync -> [Text.Builder] syncLines sync =- colorize (Text.italic (" " <> sync.source <> " → " <> sync.target)) :+ colorize+ ( Text.Builder.italic+ (" " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)+ ) : map ((" " <>) . prettyGitCommitInfo) (toList @Seq commits') ++ (if more then [" ...", ""] else [""]) where- colorize :: Text -> Text+ colorize :: Text.Builder -> Text.Builder colorize = case sync.result of- SyncResult'Failure -> Text.red- SyncResult'Offline -> Text.brightBlack- SyncResult'Pending -> Text.yellow- SyncResult'Success -> Text.green+ SyncResult'Failure -> Text.Builder.red+ SyncResult'Offline -> Text.Builder.brightBlack+ SyncResult'Pending -> Text.Builder.yellow+ SyncResult'Success -> Text.Builder.green (commits', more) = case Seq1.length sync.commits > 10 of False -> (Seq1.toSeq sync.commits, False) True -> (Seq1.dropEnd 1 sync.commits, True)- undoLines :: [Text]+ undoLines :: [Text.Builder] undoLines = if summary.canUndo- then [" Run " <> Text.bold (Text.blue "mit undo") <> " to undo this change.", ""]+ then [" Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change.", ""] else [] -- State file
src/Mit/Git.hs view
@@ -6,7 +6,11 @@ import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.ANSI as Text+import qualified Data.Text.Builder.ANSI as Text.Builder import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Text.Lazy.Builder as Text (Builder)+import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Ki import Mit.Globals (debug) import Mit.Prelude@@ -46,17 +50,16 @@ } deriving stock (Show) -prettyGitCommitInfo :: GitCommitInfo -> Text+prettyGitCommitInfo :: GitCommitInfo -> Text.Builder prettyGitCommitInfo info =- -- FIXME use builder fold- [ Text.bold (Text.black info.shorthash),+ [ Text.Builder.bold (Text.Builder.black (Text.Builder.fromText info.shorthash)), " ",- Text.bold (Text.white info.subject),+ Text.Builder.bold (Text.Builder.white (Text.Builder.fromText info.subject)), " - ",- Text.italic (Text.white info.author),+ Text.Builder.italic (Text.Builder.white (Text.Builder.fromText info.author)), " ",- Text.italic (Text.yellow info.date) -- FIXME some other color, magenta?+ Text.Builder.italic (Text.Builder.yellow (Text.Builder.fromText info.date)) -- FIXME some other color, magenta? ] data GitConflict@@ -68,10 +71,9 @@ [xy, name] <- Just (Text.words line) GitConflict <$> parseGitConflictXY xy <*> Just name --- FIXME builder-showGitConflict :: GitConflict -> Text+showGitConflict :: GitConflict -> Text.Builder showGitConflict (GitConflict xy name) =- name <> " (" <> showGitConflictXY xy <> ")"+ Text.Builder.fromText name <> " (" <> showGitConflictXY xy <> ")" data GitConflictXY = AA -- both added@@ -94,8 +96,7 @@ "UU" -> Just UU _ -> Nothing --- FIXME builder-showGitConflictXY :: GitConflictXY -> Text+showGitConflictXY :: GitConflictXY -> Text.Builder showGitConflictXY = \case AA -> "both added" AU -> "added by us"@@ -117,7 +118,7 @@ gitApplyStash :: Text -> IO [GitConflict] gitApplyStash stash = do conflicts <-- git ["stash", "apply", stash] >>= \case+ gitl ["stash", "apply", stash] >>= \case False -> gitConflicts True -> pure [] gitUnstageChanges@@ -126,7 +127,7 @@ -- | Create a branch. gitBranch :: Text -> IO () gitBranch branch =- git_ ["branch", "--no-track", branch]+ gitl_ ["branch", "--no-track", branch] -- | Does the given local branch (refs/heads/...) exist? gitBranchExists :: Text -> IO Bool@@ -144,18 +145,18 @@ gitBranchWorktreeDir :: Text -> IO (Maybe Text) gitBranchWorktreeDir branch = do worktrees <- gitWorktreeList- case List.find (\worktree -> worktree.branch == Just branch) worktrees of- Nothing -> pure Nothing- Just worktree -> pure (Just worktree.directory)+ pure case List.find (\worktree -> worktree.branch == Just branch) worktrees of+ Nothing -> Nothing+ Just worktree -> Just worktree.directory gitCommit :: IO Bool gitCommit = queryTerminal 0 >>= \case False -> do message <- lookupEnv "MIT_COMMIT_MESSAGE"- git ["commit", "--all", "--message", maybe "" Text.pack message]+ gitl ["commit", "--all", "--message", maybe "" Text.pack message] True ->- git2 ["commit", "--patch", "--quiet"] <&> \case+ gitl2 ["commit", "--patch", "--quiet"] <&> \case ExitFailure _ -> False ExitSuccess -> True @@ -194,7 +195,7 @@ gitCreateStash :: IO Text gitCreateStash = do git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed- stash <- git ["stash", "create"]+ stash <- gitl ["stash", "create"] gitUnstageChanges pure stash @@ -224,7 +225,7 @@ gitFetch :: Text -> IO Bool gitFetch remote =- git ["fetch", remote]+ gitl ["fetch", remote] gitFetch_ :: Text -> IO () gitFetch_ =@@ -242,30 +243,31 @@ -- FIXME document what this does gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ()) gitMerge me target = do- git ["merge", "--ff", "--no-commit", target] >>= \case+ gitl ["merge", "--ff", "--no-commit", target] >>= \case False -> (pure . Left) do conflicts <- gitConflicts- git_ ["add", "--all"]- git_ ["commit", "--no-edit", "--message", mergeMessage conflicts]+ gitl_ ["add", "--all"]+ gitl_ ["commit", "--no-edit", "--message", mergeMessage conflicts] pure conflicts True -> do- whenM gitMergeInProgress (git_ ["commit", "--message", mergeMessage []])+ whenM gitMergeInProgress (gitl_ ["commit", "--message", mergeMessage []]) pure (Right ()) where mergeMessage :: [GitConflict] -> Text mergeMessage conflicts =- -- FIXME use builder- fold+ (Text.Lazy.toStrict . Text.Builder.toLazyText . fold) [ "⅄", if null conflicts then "" else "\x0338", " ",- if target' == me then me else target' <> " → " <> me,+ if target' == me+ then Text.Builder.fromText me+ else Text.Builder.fromText target' <> " → " <> Text.Builder.fromText me, if null conflicts then "" else " (conflicts)\n\nConflicting files:\n"- <> Text.intercalate "\n" (map ((" " <>) . showGitConflict) conflicts)+ <> mconcat (List.intersperse "\n" (map ((" " <>) . showGitConflict) conflicts)) ] where target' :: Text@@ -278,7 +280,7 @@ gitPush :: Text -> IO Bool gitPush branch =- git ["push", "--set-upstream", "origin", branch <> ":" <> branch]+ gitl ["push", "--set-upstream", "origin", branch <> ":" <> branch] -- | Does the given remote branch (refs/remotes/...) exist? gitRemoteBranchExists :: Text -> Text -> IO Bool@@ -295,12 +297,12 @@ -- | Blow away untracked files, and hard-reset to the given commit gitResetHard :: Text -> IO () gitResetHard commit = do- git_ ["clean", "-d", "--force"]- git ["reset", "--hard", commit]+ gitl_ ["clean", "-d", "--force"]+ gitl ["reset", "--hard", commit] gitRevert :: Text -> IO () gitRevert commit =- git_ ["revert", commit]+ gitl_ ["revert", commit] -- | Stash uncommitted changes (if any). gitStash :: IO (Maybe Text)@@ -318,9 +320,9 @@ gitUnstageChanges :: IO () gitUnstageChanges = do- git_ ["reset", "--mixed"]+ gitl_ ["reset", "--mixed"] untrackedFiles <- gitListUntrackedFiles- unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles))+ unless (null untrackedFiles) (gitl_ ("add" : "--intent-to-add" : untrackedFiles)) gitVersion :: IO GitVersion gitVersion = do@@ -363,7 +365,15 @@ pure (url, Text.takeWhileEnd (/= '/') url') git :: ProcessOutput a => [Text] -> IO a-git args = do+git =+ git' False++gitl :: ProcessOutput a => [Text] -> IO a+gitl =+ git' True++git' :: ProcessOutput a => Bool -> [Text] -> IO a+git' effectful args = do let spec :: CreateProcess spec = CreateProcess@@ -384,6 +394,7 @@ detach_console = False, use_process_jobs = False }+ when effectful (logProcess "git" args) bracket (createProcess spec) cleanup \(_maybeStdin, maybeStdout, maybeStderr, processHandle) -> Ki.scoped \scope -> do stdoutThread <- Ki.fork scope (drainTextHandle (fromJust maybeStdout))@@ -417,9 +428,14 @@ git_ = git +gitl_ :: [Text] -> IO ()+gitl_ =+ gitl+ -- Yucky interactive/inherity variant (so 'git commit' can open an editor).-git2 :: [Text] -> IO ExitCode-git2 args = do+gitl2 :: [Text] -> IO ExitCode+gitl2 args = do+ logProcess "git" args (Nothing, Nothing, Just stderrHandle, processHandle) <- createProcess CreateProcess
src/Mit/Process.hs view
@@ -4,7 +4,22 @@ import qualified Data.Sequence as Seq import Mit.Prelude+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.List as List+import qualified Data.Text.Builder.ANSI as Text.Builder+import qualified Data.Text.Lazy.Builder as Text.Builder import System.Exit (ExitCode (..), exitWith)++logProcess :: Text -> [Text] -> IO ()+logProcess s0 ss =+ Text.putStrLn (Text.Lazy.toStrict (Text.Builder.toLazyText line))+ where+ line = "» " <> Text.Builder.bold (Text.Builder.fromText s0 <> space <> formatArgs ss)+ formatArgs = mconcat . List.intersperse space . map formatArg+ formatArg s = Text.Builder.fromText (if Text.elem ' ' s then s else s)+ space = Text.Builder.singleton ' ' class ProcessOutput a where fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO a