diff --git a/mit-3qvpPyAi6mH.cabal b/mit-3qvpPyAi6mH.cabal --- a/mit-3qvpPyAi6mH.cabal +++ b/mit-3qvpPyAi6mH.cabal @@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX -version: 3 +version: 4 description: A git wrapper with a streamlined UX. @@ -25,8 +25,10 @@ build-depends: base < 5, base64, + containers, clock, directory, + ki, process, record-dot-preprocessor, record-hasfield, @@ -41,6 +43,7 @@ DuplicateRecordFields FlexibleInstances GADTs + GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf @@ -64,12 +67,14 @@ Mit.Globals Mit.Prelude Mit.Process + Mit.Seq1 hs-source-dirs: src executable mit import: component build-depends: mit-3qvpPyAi6mH, + ghc-options: -threaded -with-rtsopts=-N2 hs-source-dirs: app main-is: Main.hs diff --git a/src/Mit.hs b/src/Mit.hs --- a/src/Mit.hs +++ b/src/Mit.hs @@ -4,12 +4,14 @@ module Mit where import qualified Data.List.NonEmpty as List1 +import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.ANSI as Text import qualified Data.Text.Encoding.Base64 as Text import qualified Data.Text.IO as Text import Mit.Git import Mit.Prelude +import qualified Mit.Seq1 as Seq1 import qualified System.Clock as Clock import System.Directory (doesDirectoryExist, removeFile, withCurrentDirectory) import System.Environment (getArgs) @@ -18,8 +20,7 @@ -- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit -- ephemeral feeling -- FIXME bail if active cherry-pick, active revert, active rebase, what else? --- FIXME rev-list max 11, use ellipses after 10 --- FIXME test file deleted by us/them conflict +-- FIXME more Seq, less [] -- TODO mit init -- TODO mit delete-branch @@ -36,7 +37,6 @@ main = do getArgs >>= \case ["branch", branch] -> mitBranch (Text.pack branch) - ["clone", parseGitRepo . Text.pack -> Just (url, name)] -> mitClone url name ["commit"] -> mitCommit ["merge", branch] -> mitMerge (Text.pack branch) ["sync"] -> mitSync @@ -122,23 +122,18 @@ where worktreeDir :: Text worktreeDir = - Text.dropWhileEnd (/= '/') gitdir <> branch - -mitClone :: Text -> Text -> IO () -mitClone url name = - -- FIXME use 'git config --get init.defaultBranch' - git ["clone", url, "--separate-git-dir", name <> "/.git", name <> "/master"] + Text.dropWhileEnd (/= '/') rootdir <> branch mitCommit :: IO () mitCommit = do dieIfNotInGitDir whenM gitExistUntrackedFiles dieIfBuggyGit - gitDiff >>= \case - Differences -> - gitMergeInProgress >>= \case - False -> mitCommit_ - True -> mitCommitMerge - NoDifferences -> exitFailure + gitMergeInProgress >>= \case + False -> + gitDiff >>= \case + Differences -> mitCommit_ + NoDifferences -> exitFailure + True -> mitCommitMerge mitCommit_ :: IO () mitCommit_ = do @@ -170,7 +165,7 @@ writeMitState branch64 state0 {ranCommitAt} putLines [ "", - " " <> Text.italic branch <> " is not up to date.", + " " <> Text.yellow (Text.italic branch <> " is not up to date."), "", " Run " <> Text.bold (Text.blue "mit sync") <> " first, or run " <> Text.bold (Text.blue "mit commit") <> " again to record a commit anyway.", @@ -184,10 +179,10 @@ pushResult <- case (localCommits, existRemoteCommits, fetched) of - ([], _, _) -> pure (PushNotAttempted NothingToPush) - (_ : _, True, _) -> pure (PushNotAttempted ForkedHistory) - (_ : _, False, False) -> pure (PushNotAttempted Offline) - (_ : _, False, True) -> PushAttempted <$> gitPush branch + (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush) + (_ Seq.:<| _, True, _) -> pure (PushNotAttempted ForkedHistory) + (_ Seq.:<| _, False, False) -> pure (PushNotAttempted Offline) + (_ Seq.:<| _, False, True) -> PushAttempted <$> gitPush branch let pushed = case pushResult of @@ -204,7 +199,7 @@ case (pushed, committed, localCommits) of (False, False, _) -> pure state0.undos (False, True, _) -> pure [Reset head, Apply stash] - (True, True, [_]) -> do + (True, True, _ Seq.:<| Seq.Empty) -> do head1 <- gitHead pure [Revert head1, Apply stash] (True, _, _) -> pure [] @@ -223,7 +218,7 @@ canUndo = not (null undos) && committed, conflicts = [], syncs = - case List1.nonEmpty localCommits of + case Seq1.fromSeq localCommits of Nothing -> [] Just commits -> [ Sync @@ -342,7 +337,7 @@ } data MergeStatus = MergeStatus - { commits :: List1 GitCommitInfo, + { commits :: Seq1 GitCommitInfo, result :: MergeResult, undos :: [Undo] -- FIXME List1 } @@ -354,7 +349,7 @@ mitMerge' :: Text -> Text -> IO (Maybe MergeStatus) mitMerge' message target = do head <- gitHead - (List1.nonEmpty <$> gitCommitsBetween (Just head) target) >>= \case + (Seq1.fromSeq <$> gitCommitsBetween (Just head) target) >>= \case Nothing -> pure Nothing Just commits -> do maybeStash <- gitStash @@ -363,6 +358,25 @@ git ["merge", "--ff", "--no-commit", target] >>= \case False -> do conflicts <- gitConflicts + -- error: The following untracked working tree files would be overwritten by merge: + -- administration-client/administration-client.cabal + -- aeson-simspace/aeson-simspace.cabal + -- attack-designer/api/attack-designer-api.cabal + -- attack-designer/db/attack-designer-db.cabal + -- attack-designer/server/attack-designer-server.cabal + -- attack-integrations/attack-integrations.cabal + -- authz/simspace-authz.cabal + -- caching/caching.cabal + -- common-testlib/common-testlib.cabal + -- db-infra/db-infra.cabal + -- db-infra/migrations/0_migrate-rich-text-images-to-minio/migrate-rich-text-images-to-minio.cabal + -- db-infra/migrations/2.0.0.1010_migrate-questions-into-content-modules/range-data-server-migrate-questions-into-content-modules.cabal + -- db-infra/migrations/2.0.0.19_migrate-hello-table/range-data-server-migrate-hello-table.cabal + -- db-infra/migrations/2.0.0.21_migrate-puppet-yaml-to-text/range-data-server-migrate-puppet-yaml-to-text.cabal + -- db-infra/migrations/2.0.0.9015_migrate-refresh-stocks/range-data-server-migrate-refresh-stocks.cabal + -- db-infra/migrations/shared/range-data-server-migration.cabal + -- Please move or remove them before you merge. + -- Aborting pure (MergeResult'MergeConflicts (List1.fromList conflicts)) True -> do whenM gitMergeInProgress (git_ ["commit", "--message", message]) @@ -414,14 +428,14 @@ pushResult <- case (localCommits, (.result) <$> maybeMergeStatus, fetched) of - ([], _, _) -> pure (PushNotAttempted NothingToPush) + (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush) -- "forked history" is ok - a bit different than history *already* having forked, in which case a push -- would just fail, whereas this is just us choosing not to push while in the middle of a merge due to a -- previous fork in the history - (_ : _, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory) - (_ : _, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits) - (_ : _, Nothing, False) -> pure (PushNotAttempted Offline) - (_ : _, Nothing, True) -> PushAttempted <$> gitPush branch + (_ Seq.:<| _, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory) + (_ Seq.:<| _, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits) + (_ Seq.:<| _, Nothing, False) -> pure (PushNotAttempted Offline) + (_ Seq.:<| _, Nothing, True) -> PushAttempted <$> gitPush branch let pushed = case pushResult of @@ -472,7 +486,7 @@ target = branch }, do - commits <- List1.nonEmpty localCommits + commits <- Seq1.fromSeq localCommits pure Sync { commits, @@ -509,7 +523,7 @@ } data Sync = Sync - { commits :: List1 GitCommitInfo, + { commits :: Seq1 GitCommitInfo, result :: SyncResult, source :: Text, target :: Text @@ -537,8 +551,8 @@ syncLines :: Sync -> [Text] syncLines sync = colorize (Text.italic (" " <> sync.source <> " → " <> sync.target)) : - map ((" " <>) . prettyGitCommitInfo) (List1.toList sync.commits) - ++ [""] + map ((" " <>) . prettyGitCommitInfo) (toList @Seq commits') + ++ (if more then [" ...", ""] else [""]) where colorize :: Text -> Text colorize = @@ -547,6 +561,10 @@ SyncResult'Offline -> Text.brightBlack SyncResult'Pending -> Text.yellow SyncResult'Success -> Text.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 = if summary.canUndo diff --git a/src/Mit/Git.hs b/src/Mit/Git.hs --- a/src/Mit/Git.hs +++ b/src/Mit/Git.hs @@ -3,24 +3,36 @@ module Mit.Git where import qualified Data.List as List +import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Data.Text.ANSI as Text +import qualified Data.Text.IO as Text +import qualified Ki import Mit.Globals (debug) import Mit.Prelude import Mit.Process import System.Directory (doesFileExist) import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) +import System.IO (Handle, hClose, hIsEOF) import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Process (getProcessGroupIDOf) +import System.Posix.Signals import System.Posix.Terminal (queryTerminal) import System.Process +import System.Process.Internals --- FIXME this finds the wrong dir for worktrees 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 @@ -147,10 +159,10 @@ ExitFailure _ -> False ExitSuccess -> True -gitCommitsBetween :: Maybe Text -> Text -> IO [GitCommitInfo] +gitCommitsBetween :: Maybe Text -> Text -> IO (Seq GitCommitInfo) gitCommitsBetween commit1 commit2 = if commit1 == Just commit2 - then pure [] + then pure Seq.empty else do commits <- -- --first-parent seems desirable for topic branches @@ -159,15 +171,15 @@ "--color=always", "--date=human", "--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s", - "--max-count=10", + "--max-count=11", maybe id (\c1 c2 -> c1 <> ".." <> c2) commit1 commit2 ] - pure (map parseCommitInfo (dropEvens commits)) + pure (parseCommitInfo <$> dropEvens commits) where -- git rev-list with a custom format prefixes every commit with a redundant line :| - dropEvens :: [a] -> [a] + dropEvens :: Seq a -> Seq a dropEvens = \case - _ : x : xs -> x : dropEvens xs + _ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs xs -> xs parseCommitInfo :: Text -> GitCommitInfo parseCommitInfo line = @@ -352,31 +364,54 @@ git :: ProcessOutput a => [Text] -> IO a git args = do - (Nothing, Just stdoutHandle, 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 = False, - env = Nothing, - new_session = False, - std_err = CreatePipe, - std_in = NoStream, - std_out = CreatePipe, - -- windows-only - create_new_console = False, - detach_console = False, - use_process_jobs = False - } - exitCode <- waitForProcess processHandle - stdoutLines <- drainTextHandle stdoutHandle - stderrLines <- drainTextHandle stderrHandle - debugPrintGit args stdoutLines stderrLines exitCode - fromProcessOutput stdoutLines stderrLines exitCode + let spec :: CreateProcess + spec = + CreateProcess + { child_group = Nothing, + child_user = Nothing, + close_fds = True, + cmdspec = RawCommand "git" (map Text.unpack args), + create_group = False, + cwd = Nothing, + delegate_ctlc = False, + env = Nothing, + new_session = False, + std_err = CreatePipe, + std_in = NoStream, + std_out = CreatePipe, + -- windows-only + create_new_console = False, + detach_console = False, + use_process_jobs = False + } + 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 + where + cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () + cleanup (maybeStdin, maybeStdout, maybeStderr, process) = + void @_ @ExitCode terminate `finally` closeHandles + where + closeHandles :: IO () + closeHandles = + whenJust maybeStdin hClose + `finally` whenJust maybeStdout hClose + `finally` whenJust maybeStderr hClose + terminate :: IO ExitCode + terminate = do + withProcessHandle process \case + ClosedHandle _ -> pure () + OpenExtHandle {} -> bug "OpenExtHandle is Windows-only" + OpenHandle pid -> do + pgid <- getProcessGroupIDOf pid + signalProcessGroup sigTERM pgid + waitForProcess process git_ :: [Text] -> IO () git_ = @@ -410,16 +445,16 @@ UserInterrupt -> pure (ExitFailure (-130)) exception -> throwIO exception stderrLines <- drainTextHandle stderrHandle - debugPrintGit args [] stderrLines exitCode + debugPrintGit args Seq.empty stderrLines exitCode pure exitCode -debugPrintGit :: [Text] -> [Text] -> [Text] -> ExitCode -> IO () +debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO () debugPrintGit args stdoutLines stderrLines exitCode = when debug do putLines do let output :: [Text] output = - map (Text.brightBlack . (" " <>)) (stdoutLines ++ stderrLines) + map (Text.brightBlack . (" " <>)) (toList @Seq (stdoutLines <> stderrLines)) Text.bold (Text.brightBlack (Text.unwords (marker <> " git" : map quoteText args))) : output where marker :: Text @@ -427,3 +462,13 @@ case exitCode of ExitFailure _ -> "✗" ExitSuccess -> "✓" + +drainTextHandle :: Handle -> IO (Seq Text) +drainTextHandle handle = do + let loop acc = + hIsEOF handle >>= \case + False -> do + line <- Text.hGetLine handle + loop $! acc Seq.|> line + True -> pure acc + loop Seq.empty diff --git a/src/Mit/Prelude.hs b/src/Mit/Prelude.hs --- a/src/Mit/Prelude.hs +++ b/src/Mit/Prelude.hs @@ -12,11 +12,12 @@ import Data.Function as X import qualified Data.List.NonEmpty as List1 import Data.Maybe as X +import Data.Sequence as X (Seq) import Data.Text as X (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Traversable as X -import System.IO (Handle, hIsEOF) +import Mit.Seq1 as X (Seq1) import Text.Read as X (readMaybe) import Prelude as X hiding (head, id) @@ -31,16 +32,6 @@ bug = error . Text.unpack -drainTextHandle :: Handle -> IO [Text] -drainTextHandle handle = do - let loop acc = - hIsEOF handle >>= \case - False -> do - line <- Text.hGetLine handle - loop (line : acc) - True -> pure (reverse acc) - loop [] - -- FIXME make this faster int2text :: Integer -> Text int2text = @@ -72,6 +63,10 @@ mx >>= \case False -> action True -> pure () + +whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust = + for_ whenM :: Monad m => m Bool -> m () -> m () whenM mx action = diff --git a/src/Mit/Process.hs b/src/Mit/Process.hs --- a/src/Mit/Process.hs +++ b/src/Mit/Process.hs @@ -2,11 +2,12 @@ module Mit.Process where +import qualified Data.Sequence as Seq import Mit.Prelude import System.Exit (ExitCode (..), exitWith) class ProcessOutput a where - fromProcessOutput :: [Text] -> [Text] -> ExitCode -> IO a + fromProcessOutput :: Seq Text -> Seq Text -> ExitCode -> IO a instance ProcessOutput () where fromProcessOutput _ _ code = @@ -21,13 +22,12 @@ fromProcessOutput out _ code = do when (code /= ExitSuccess) (exitWith code) case out of - [] -> throwIO (userError "no stdout") - line : _ -> pure line + Seq.Empty -> throwIO (userError "no stdout") + line Seq.:<| _ -> pure line instance a ~ Text => ProcessOutput [a] where - fromProcessOutput out _ code = do - when (code /= ExitSuccess) (exitWith code) - pure out + fromProcessOutput out err code = + toList @Seq <$> fromProcessOutput out err code instance a ~ ExitCode => ProcessOutput (Either a Text) where fromProcessOutput out _ code = @@ -35,10 +35,17 @@ ExitFailure _ -> pure (Left code) ExitSuccess -> case out of - [] -> throwIO (userError "no stdout") - line : _ -> pure (Right line) + Seq.Empty -> throwIO (userError "no stdout") + line Seq.:<| _ -> pure (Right line) instance a ~ Text => ProcessOutput (Maybe a) where fromProcessOutput out _ code = do when (code /= ExitSuccess) (exitWith code) - pure (listToMaybe out) + case out of + Seq.Empty -> pure Nothing + line Seq.:<| _ -> pure (Just line) + +instance a ~ Text => ProcessOutput (Seq a) where + fromProcessOutput out _ code = do + when (code /= ExitSuccess) (exitWith code) + pure out diff --git a/src/Mit/Seq1.hs b/src/Mit/Seq1.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Seq1.hs @@ -0,0 +1,38 @@ +module Mit.Seq1 where + +import Data.Coerce +import qualified Data.Foldable +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Prelude + +newtype Seq1 a = Seq1 + {unSeq1 :: Seq a} + deriving newtype (Foldable) + +dropEnd :: Int -> Seq1 a -> Seq a +dropEnd = + let loop n = + case n of + 0 -> id + _ -> \case + Seq.Empty -> Seq.Empty + ys Seq.:|> _ -> loop (n -1) ys + in \n (Seq1 xs) -> loop n xs + +fromSeq :: Seq a -> Maybe (Seq1 a) +fromSeq = \case + Seq.Empty -> Nothing + xs -> Just (Seq1 xs) + +length :: forall a. Seq1 a -> Int +length = + coerce (Seq.length @a) + +toList :: forall a. Seq1 a -> [a] +toList = + coerce (Data.Foldable.toList @Seq @a) + +toSeq :: Seq1 a -> Seq a +toSeq = + coerce