mit-3qvpPyAi6mH 1 → 2
raw patch · 2 files changed
+143/−59 lines, 2 files
Files
- Main.hs +141/−57
- mit-3qvpPyAi6mH.cabal +2/−2
Main.hs view
@@ -114,21 +114,20 @@ case List.find (\(_, _, worktreeBranch) -> worktreeBranch == Just branch) worktrees of Nothing -> do- git_ ["worktree", "add", "--detach", "--quiet", worktreeDir]+ git_ ["worktree", "add", "--detach", worktreeDir] withCurrentDirectory (Text.unpack worktreeDir) do- git ["rev-parse", "--quiet", "--verify", "refs/heads/" <> branch] >>= \case+ git ["rev-parse", "--verify", "refs/heads/" <> branch] >>= \case False -> do git_ ["branch", "--no-track", branch]- git_ ["switch", "--quiet", branch]+ git_ ["switch", branch] _fetchResult :: Bool <-- git ["fetch", "--quiet", "origin"]+ git ["fetch", "origin"] - whenM (git ["rev-parse", "--quiet", "--verify", "refs/remotes/" <> upstream]) do- git_ ["reset", "--hard", "--quiet", upstream]+ whenM (git ["rev-parse", "--verify", "refs/remotes/" <> upstream]) do+ git_ ["reset", "--hard", upstream] git_ ["branch", "--set-upstream-to", upstream]- True ->- git_ ["switch", "--quiet", branch]+ True -> git_ ["switch", branch] Just (dir, _, _) -> unless (worktreeDir == dir) do Text.putStrLn ("Branch " <> Text.bold branch <> " is already checked out in " <> Text.bold dir)@@ -189,7 +188,7 @@ exitFailure stash :: Text <-- git ["stash", "create"]+ gitCreateStash commitResult :: Bool <- gitCommit@@ -287,7 +286,7 @@ -- When given 'mit merge foo', prefer merging 'origin/foo' over 'foo' target :: Text <- do let remote = "origin/" <> target0- git ["rev-parse", "--quiet", "--verify", remote] <&> \case+ git ["rev-parse", "--verify", remote] <&> \case False -> target0 True -> remote @@ -306,7 +305,7 @@ (_ : _, Differences) -> Just <$> gitStash _ -> pure Nothing - mergeConflicts :: Maybe [Text] <-+ mergeConflicts :: Maybe [GitConflict] <- case targetCommits of [] -> pure Nothing _ ->@@ -315,7 +314,7 @@ Left commitConflicts -> commitConflicts Right () -> pure [] - stashConflicts :: [Text] <-+ stashConflicts :: [GitConflict] <- case maybeStash of Nothing -> pure [] Just stash -> gitApplyStash stash@@ -332,6 +331,7 @@ Summary { branch = context.branch, canUndo,+ -- FIXME this is dubious, nub made more sense when conflicts were just filenames... conflicts = List.nub (stashConflicts ++ fromMaybe [] mergeConflicts), syncs = [ Sync@@ -372,7 +372,7 @@ (_ : _, Differences) -> Just <$> gitStash _ -> pure Nothing - mergeConflicts :: Maybe [Text] <-+ mergeConflicts :: Maybe [GitConflict] <- case remoteCommits of [] -> pure Nothing _ ->@@ -384,7 +384,7 @@ localCommits :: [GitCommitInfo] <- gitCommitsBetween maybeUpstreamHead "HEAD" - stashConflicts :: [Text] <-+ stashConflicts :: [GitConflict] <- case maybeStash of Nothing -> pure [] Just stash -> gitApplyStash stash@@ -420,6 +420,7 @@ Summary { branch = context.branch, canUndo,+ -- FIXME this is dubious, nub made more sense when conflicts were just filenames... conflicts = List.nub (stashConflicts ++ fromMaybe [] mergeConflicts), syncs = [ Sync@@ -451,8 +452,12 @@ Just undos -> do deleteUndoFile branch64 for_ undos \case- Apply commit -> git_ ["stash", "apply", "--quiet", commit]- Reset commit -> git_ ["reset", "--hard", "--quiet", commit]+ Apply commit -> do+ -- This should never return conflicts+ -- FIXME assert?+ _conflicts <- gitApplyStash commit+ pure ()+ Reset commit -> gitResetHard commit Revert commit -> git_ ["revert", commit] when (undosContainRevert undos) mitSync where@@ -476,7 +481,7 @@ branch <- gitCurrentBranch dirty <- gitDiff head <- git ["rev-parse", "HEAD"]- fetchFailed <- not <$> git ["fetch", "--quiet", "origin"]+ fetchFailed <- not <$> git ["fetch", "origin"] pure Context { branch,@@ -490,7 +495,7 @@ data Summary = Summary { branch :: Text, canUndo :: Bool,- conflicts :: [Text],+ conflicts :: [GitConflict], syncs :: [Sync] } @@ -517,7 +522,9 @@ conflictsLines = if null summary.conflicts then []- else " The following files have conflicts." : map ((" " <>) . Text.red) summary.conflicts ++ [""]+ else+ " The following files have conflicts." :+ map ((" " <>) . Text.red . showGitConflict) summary.conflicts ++ [""] syncLines :: Sync -> [Text] syncLines sync = if null sync.commits@@ -678,6 +685,52 @@ Text.italic (Text.yellow info.date) -- FIXME some other color, magenta? ] +data GitConflict+ = GitConflict GitConflictXY Text+ deriving stock (Eq)++parseGitConflict :: Text -> Maybe GitConflict+parseGitConflict line = do+ [xy, name] <- Just (Text.words line)+ GitConflict <$> parseGitConflictXY xy <*> Just name++-- FIXME builder+showGitConflict :: GitConflict -> Text+showGitConflict (GitConflict xy name) =+ name <> " (" <> showGitConflictXY xy <> ")"++data GitConflictXY+ = AA -- both added+ | AU -- added by us+ | DD -- both deleted+ | DU -- deleted by us+ | UA -- added by them+ | UD -- deleted by them+ | UU -- both modified+ deriving stock (Eq)++parseGitConflictXY :: Text -> Maybe GitConflictXY+parseGitConflictXY = \case+ "AA" -> Just AA+ "AU" -> Just AU+ "DD" -> Just DD+ "DU" -> Just DU+ "UA" -> Just UA+ "UD" -> Just UD+ "UU" -> Just UU+ _ -> Nothing++-- FIXME builder+showGitConflictXY :: GitConflictXY -> Text+showGitConflictXY = \case+ AA -> "both added"+ AU -> "added by us"+ DD -> "both deleted"+ DU -> "deleted by us"+ UA -> "added by them"+ UD -> "deleted by them"+ UU -> "both modified"+ data GitVersion = GitVersion Int Int Int deriving stock (Eq, Ord)@@ -687,21 +740,21 @@ Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z) -- | Apply stash, return conflicts.-gitApplyStash :: Text -> IO [Text]+gitApplyStash :: Text -> IO [GitConflict] gitApplyStash stash = do- git ["stash", "apply", "--quiet", stash] >>= \case- False -> do- conflicts <- git ["diff", "--name-only", "--diff-filter=U"]- git_ ["reset", "--quiet"] -- unmerged (weird) -> unstaged (normal)- pure conflicts- True -> pure []+ conflicts <-+ git ["stash", "apply", stash] >>= \case+ False -> gitConflicts+ True -> pure []+ gitUnstageChanges+ pure conflicts gitCommit :: IO Bool gitCommit = queryTerminal 0 >>= \case False -> do message <- lookupEnv "MIT_COMMIT_MESSAGE"- git ["commit", "--all", "--message", maybe "" Text.pack message, "--quiet"]+ git ["commit", "--all", "--message", maybe "" Text.pack message] True -> git2 ["commit", "--patch", "--quiet"] <&> \case ExitFailure _ -> False@@ -735,40 +788,55 @@ [author, date, hash, shorthash, subject] -> GitCommitInfo {author, date, hash, shorthash, subject} _ -> error (Text.unpack line) +gitCreateStash :: IO Text+gitCreateStash = do+ git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed+ stash <- git ["stash", "create"]+ gitUnstageChanges+ pure stash+ -- | Get the current branch. gitCurrentBranch :: IO Text gitCurrentBranch = git ["branch", "--show-current"] --- | Do any untracked files exist?-gitExistUntrackedFiles :: IO Bool-gitExistUntrackedFiles = do- files :: [Text] <- git ["ls-files", "--exclude-standard", "--other"]- pure (not (null files))-+-- FIXME document this gitDiff :: IO DiffResult gitDiff = do- git_ ["reset", "--quiet"]- git_ ["add", "--all", "--intent-to-add"]+ gitUnstageChanges git ["diff", "--quiet"] <&> \case False -> Differences True -> NoDifferences +-- | Do any untracked files exist?+gitExistUntrackedFiles :: IO Bool+gitExistUntrackedFiles =+ not . null <$> gitListUntrackedFiles++gitConflicts :: IO [GitConflict]+gitConflicts =+ mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"]++-- | List all untracked files.+gitListUntrackedFiles :: IO [Text]+gitListUntrackedFiles =+ git ["ls-files", "--exclude-standard", "--other"]+ -- FIXME document what this does-gitMerge :: Text -> Text -> IO (Either (IO [Text]) ())+gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ()) gitMerge me target = do- git ["merge", "--ff", "--no-commit", "--quiet", target] >>= \case+ git ["merge", "--ff", "--no-commit", target] >>= \case False -> (pure . Left) do- conflicts <- git ["diff", "--name-only", "--diff-filter=U"]+ conflicts <- gitConflicts git_ ["add", "--all"]- git_ ["commit", "--no-edit", "--quiet", "--message", mergeMessage conflicts]+ git_ ["commit", "--no-edit", "--message", mergeMessage conflicts] pure conflicts True -> do whenM gitMergeInProgress (git_ ["commit", "--message", mergeMessage []]) pure (Right ()) where- mergeMessage :: [Text] -> Text+ mergeMessage :: [GitConflict] -> Text mergeMessage conflicts = -- FIXME use builder fold@@ -778,7 +846,9 @@ if target' == me then me else target' <> " → " <> me, if null conflicts then ""- else " (conflicts)\n\nConflicting files:\n" <> Text.intercalate "\n" (map (" " <>) conflicts)+ else+ " (conflicts)\n\nConflicting files:\n"+ <> Text.intercalate "\n" (map ((" " <>) . showGitConflict) conflicts) ] where target' :: Text@@ -791,15 +861,27 @@ gitPush :: Text -> IO Bool gitPush branch =- git ["push", "--quiet", "--set-upstream", "origin", branch <> ":" <> branch]+ git ["push", "--set-upstream", "origin", branch <> ":" <> branch] +-- | 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]+ -- | Create a stash and blow away local changes (like 'git stash push') gitStash :: IO Text gitStash = do- stash <- git ["stash", "create"]- git_ ["reset", "--hard", "--quiet", "HEAD"]+ stash <- gitCreateStash+ gitResetHard "HEAD" pure stash +gitUnstageChanges :: IO ()+gitUnstageChanges = do+ git_ ["reset"]+ untrackedFiles <- gitListUntrackedFiles+ unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles))+ gitVersion :: IO GitVersion gitVersion = do v0 <- git ["--version"]@@ -896,11 +978,7 @@ exitCode <- waitForProcess processHandle stdoutLines <- drainTextHandle stdoutHandle stderrLines <- drainTextHandle stderrHandle- when debug do- Text.putStrLn . Text.brightBlack $- Text.unwords ("git" : map quoteText args)- <> " : "- <> Text.pack (show (stdoutLines, stderrLines, exitCode))+ debugPrintGit args stdoutLines stderrLines exitCode fromProcessOutput stdoutLines stderrLines exitCode git_ :: [Text] -> IO ()@@ -910,11 +988,6 @@ -- Yucky interactive/inherity variant (so 'git commit' can open an editor). git2 :: [Text] -> IO ExitCode git2 args = do- when debug do- let quote :: Text -> Text- quote s =- if Text.any isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s- Text.putStrLn (Text.brightBlack (Text.unwords ("git" : map quote args))) (Nothing, Nothing, Just stderrHandle, processHandle) <- createProcess CreateProcess@@ -940,10 +1013,21 @@ UserInterrupt -> pure (ExitFailure (-130)) exception -> throwIO exception stderrLines <- drainTextHandle stderrHandle- when debug do- Text.putStrLn . Text.brightBlack $- Text.unwords ("git" : map quoteText args) <> " : " <> Text.pack (show (stderrLines, exitCode))+ debugPrintGit args [] stderrLines exitCode pure exitCode++debugPrintGit :: [Text] -> [Text] -> [Text] -> ExitCode -> IO ()+debugPrintGit args stdoutLines stderrLines exitCode =+ when debug do+ putLines do+ Text.bold (Text.brightBlack (Text.unwords (marker <> " git" : map quoteText args)))+ : map (Text.brightBlack . (" " <>)) (stdoutLines ++ stderrLines)+ where+ marker :: Text+ marker =+ case exitCode of+ ExitFailure _ -> "✗"+ ExitSuccess -> "✓" -- Mini prelude extensions
mit-3qvpPyAi6mH.cabal view
@@ -12,7 +12,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX-version: 1+version: 2 executable mit build-depends:@@ -44,5 +44,5 @@ UndecidableInstances ViewPatterns default-language: Haskell2010- ghc-options: -Wall -with-rtsopts=-N1+ ghc-options: -Wall main-is: Main.hs