mit-3qvpPyAi6mH 3 → 4

raw patch · 6 files changed

+197/−89 lines, 6 filesdep +containersdep +kiPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, ki

API changes (from Hackage documentation)

Files

• mit-3qvpPyAi6mH.cabal +6/−1
• src/Mit.hs +51/−33
• src/Mit/Git.hs +80/−35
• src/Mit/Prelude.hs +6/−11
• src/Mit/Process.hs +16/−9
• src/Mit/Seq1.hs +38/−0

@@ -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 

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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