diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ -module Main where +module Main (main) where -import qualified Mit +import Mit qualified import Prelude main :: IO () diff --git a/mit-3qvpPyAi6mH.cabal b/mit-3qvpPyAi6mH.cabal --- a/mit-3qvpPyAi6mH.cabal +++ b/mit-3qvpPyAi6mH.cabal @@ -3,7 +3,7 @@ author: Mitchell Rosen bug-reports: https://github.com/mitchellwrosen/mit/issues category: CLI -copyright: Copyright (C) 2020 Mitchell Rosen +copyright: Copyright (C) 2020-2022 Mitchell Rosen homepage: https://github.com/mitchellwrosen/mit license: MIT license-file: LICENSE @@ -11,34 +11,24 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX -version: 7 +version: 8 description: A git wrapper with a streamlined UX. - To install the @mit@ command-line tool, run @cabal install mit-3qvpPyAi6mH@. + To install the @mit@ command-line tool, run the following: - This package's library component does not follow the Package Versioning Policy, and is only exposed for the test - suite. + @ + cabal install -w ghc-9.2.2 mit-3qvpPyAi6mH + @ + This package's library component does not follow the Package Versioning Policy. + source-repository head type: git location: https://github.com/mitchellwrosen/mit.git common component - build-depends: - 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 @@ -48,12 +38,15 @@ FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns + NoFieldSelectors NoImplicitPrelude NumericUnderscores + OverloadedRecordDot OverloadedStrings PatternSynonyms ScopedTypeVariables @@ -62,40 +55,50 @@ UndecidableInstances ViewPatterns default-language: Haskell2010 - ghc-options: -Wall + ghc-options: + -Weverything + -Werror=incomplete-patterns + -Wno-all-missed-specialisations + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-missing-safe-haskell-mode + -Wno-unsafe library import: component + build-depends: + base == 4.16.1.0, + base64 == 0.4.2.4, + containers == 0.6.4.1, + directory == 1.3.6.2, + ki == 0.2.0.1, + optparse-applicative == 0.17.0.0, + parsec == 3.1.15.0, + process == 1.6.13.2, + text == 1.2.5.0, + text-ansi == 0.1.1, + unix == 2.7.2.2, exposed-modules: Mit Mit.Builder - Mit.Clock Mit.Config Mit.Directory Mit.Git + Mit.GitCommand Mit.Prelude Mit.Process Mit.Seq Mit.Seq1 + Mit.Stanza Mit.State Mit.Undo - ghc-options: -fplugin=RecordDotPreprocessor hs-source-dirs: src executable mit import: component build-depends: + base, mit-3qvpPyAi6mH, ghc-options: -threaded -with-rtsopts=-N2 hs-source-dirs: app main-is: Main.hs - -test-suite tests - import: component - build-depends: - free, - mit-3qvpPyAi6mH, - temporary, - hs-source-dirs: test - main-is: Main.hs - type: exitcode-stdio-1.0 diff --git a/src/Mit.hs b/src/Mit.hs --- a/src/Mit.hs +++ b/src/Mit.hs @@ -1,26 +1,27 @@ -module Mit where +module Mit + ( main, + ) +where -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty ((:|))) -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.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.Builder as Text (Builder) -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Mit.Builder as Builder -import Mit.Clock (getCurrentTime) +import Data.List.NonEmpty qualified as List1 +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.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.Prelude -import qualified Mit.Seq as Seq -import qualified Mit.Seq1 as Seq1 +import Mit.Seq1 qualified as Seq1 +import Mit.Stanza import Mit.State import Mit.Undo -import System.Environment (getArgs) +import Options.Applicative qualified as Opt +import Options.Applicative.Types qualified as Opt (Backtracking (Backtrack)) import System.Exit (ExitCode (..), exitFailure) -- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit @@ -37,29 +38,56 @@ -- TODO undo in more cases? -- TODO recommend merging master if it conflicts -- TODO mit log --- TODO optparse-applicative -- TODO undo revert -- TODO more specific "undo this change" wording main :: IO () -main = do - getArgs >>= \case - ["branch", branch] -> mitBranch (Text.pack branch) - ["commit"] -> mitCommit - ["merge", branch] -> mitMerge (Text.pack branch) - ["sync"] -> mitSync - ["undo"] -> mitUndo - _ -> do - putLines - [ "Usage:", - " mit branch ≪branch≫", - " mit clone ≪repo≫", - " mit commit", - " mit merge ≪branch≫", - " mit sync", - " mit undo" +main = + join (Opt.customExecParser parserPrefs parserInfo) + where + parserPrefs :: Opt.ParserPrefs + parserPrefs = + Opt.ParserPrefs + { prefBacktrack = Opt.Backtrack, + prefColumns = 80, + prefDisambiguate = True, + prefHelpLongEquals = False, + prefHelpShowGlobal = True, + prefMultiSuffix = "+", + prefShowHelpOnEmpty = True, + prefShowHelpOnError = True, + prefTabulateFill = 24 -- grabbed this from optparse-applicative + } + + parserInfo :: Opt.ParserInfo (IO ()) + parserInfo = + Opt.info parser $ + Opt.progDesc "mit: a git wrapper with a streamlined UX" + + parser :: Opt.Parser (IO ()) + 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).") ] - exitFailure dieIfBuggyGit :: IO () dieIfBuggyGit = do @@ -113,14 +141,14 @@ whenM (doesDirectoryExist worktreeDir) (die ["Directory " <> Text.bold worktreeDir <> " already exists."]) git_ ["worktree", "add", "--detach", worktreeDir] withCurrentDirectory worktreeDir do - whenNotM (gitSwitch branch) do + whenNotM (Git.git (Git.Switch branch)) do gitBranch branch - gitSwitch_ branch + Git.git_ (Git.Switch branch) gitFetch_ "origin" whenM (gitRemoteBranchExists "origin" branch) do let upstream = "origin/" <> branch - git_ ["reset", "--hard", upstream] - git_ ["branch", "--set-upstream-to", upstream] + Git.git_ (Git.Reset Git.Hard Git.FlagQuiet upstream) + Git.git_ (Git.BranchSetUpstreamTo upstream) Just directory -> when (directory /= worktreeDir) do die [Text.bold branch <> " is already checked out in " <> Text.bold directory <> "."] @@ -133,6 +161,7 @@ mitCommit = do dieIfNotInGitDir whenM gitExistUntrackedFiles dieIfBuggyGit + gitMergeInProgress >>= \case False -> gitDiff >>= \case @@ -142,179 +171,113 @@ mitCommit_ :: IO () mitCommit_ = do - branch <- gitCurrentBranch - let branch64 = Text.encodeBase64 branch - let upstream = "origin/" <> branch - head0 <- gitHead - state0 <- readMitState branch64 - stash <- gitCreateStash - let undos0 = [Reset head0, Apply stash] - - (fetched, maybeUpstreamHead, existRemoteCommits, wouldFork) <- do - ago <- mitStateRanCommitAgo state0 - if ago < 10_000_000_000 - then do - maybeUpstreamHead <- gitRemoteBranchHead "origin" branch - pure (True, maybeUpstreamHead, True, True) - else do - fetched <- gitFetch "origin" - maybeUpstreamHead <- gitRemoteBranchHead "origin" branch - - existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head0) maybeUpstreamHead - existLocalCommits <- - maybe - (pure True) - (\upstreamHead -> gitExistCommitsBetween upstreamHead head0) - maybeUpstreamHead - - let wouldFork = existRemoteCommits && not existLocalCommits - - when wouldFork do - applyUndo (Reset (fromJust maybeUpstreamHead)) - conflicts <- gitApplyStash stash - for_ undos0 applyUndo - - ranCommitAt <- Just <$> getCurrentTime - writeMitState branch64 state0 {ranCommitAt} + context <- getContext + let upstream = "origin/" <> context.branch - putStanzas $ - case List1.nonEmpty conflicts of - Nothing -> - [ notSynchronizedStanza - (Text.Builder.fromText branch) - (Text.Builder.fromText upstream) - ", but committing these changes would not put it in conflict.", - Just - ( " To avoid making a merge commit, run " - <> Text.Builder.bold (Text.Builder.blue "mit sync") - <> " first." - ), - Just - ( " Otherwise, run " - <> Text.Builder.bold (Text.Builder.blue "mit commit") - <> " again (within 10 seconds) to record a commit anyway." - ) - ] - Just conflicts1 -> - [ notSynchronizedStanza - (Text.Builder.fromText branch) - (Text.Builder.fromText upstream) - ", and committing these changes would put it in conflict.", - conflictsStanza "These files would be in conflict:" conflicts1, - Just - ( Builder.vcat - [ " To avoid making a merge commit, run " - <> Text.Builder.bold (Text.Builder.blue "mit sync") - <> " first to resolve conflicts.", - " (If conflicts seem too difficult to resolve, you will be able to " - <> Text.Builder.bold (Text.Builder.blue "mit undo") - <> " to back out)." - ] - ), - Just - ( " Otherwise, run " - <> Text.Builder.bold (Text.Builder.blue "mit commit") - <> " again (within 10 seconds) to record a commit anyway." - ) - ] - exitFailure + existRemoteCommits <- contextExistRemoteCommits context + existLocalCommits <- contextExistLocalCommits context - pure (fetched, maybeUpstreamHead, existRemoteCommits, wouldFork) + when (existRemoteCommits && not existLocalCommits) do + putStanzas $ + [ notSynchronizedStanza context.branch upstream ".", + runSyncStanza "Run" context.branch upstream + ] + exitFailure committed <- gitCommit - head1 <- if committed then gitHead else pure head0 - localCommits <- gitCommitsBetween maybeUpstreamHead head1 - pushResult <- - case (localCommits, existRemoteCommits, fetched) of - (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush) - (Seq.NonEmpty, True, _) -> do - conflicts <- gitConflictsWith (fromJust maybeUpstreamHead) - pure (PushNotAttempted (ForkedHistory conflicts)) - (Seq.NonEmpty, False, False) -> pure (PushNotAttempted Offline) - (Seq.NonEmpty, False, True) -> PushAttempted <$> gitPush branch - - let pushed = - case pushResult of - PushAttempted success -> success - PushNotAttempted _ -> False - - -- Only bother resetting the "ran commit at" if we would fork and the commit was aborted - ranCommitAt <- - case (wouldFork, committed) of - (True, False) -> Just <$> getCurrentTime - _ -> pure Nothing + push <- performPush context.branch - undos <- - case (pushed, committed, localCommits) of - (False, False, _) -> pure state0.undos - (False, True, _) -> pure undos0 - (True, True, Seq.Singleton) -> pure [Revert head1, Apply stash] - _ -> pure [] + let state = + MitState + { head = (), + merging = Nothing, + undos = + case (pushPushed push, committed) of + (False, False) -> context.state.undos + (False, True) -> undoToSnapshot context.snapshot + (True, False) -> push.undo + (True, True) -> + if null push.undo + then [] + else push.undo ++ [Apply (fromJust context.snapshot.stash)] + } - writeMitState branch64 MitState {head = (), merging = Nothing, ranCommitAt, undos} + writeMitState context.branch state remoteCommits <- - if existRemoteCommits - then gitCommitsBetween (Just head1) (fromJust maybeUpstreamHead) - else pure Seq.empty + case context.upstreamHead of + Nothing -> pure Seq.empty + Just upstreamHead -> gitCommitsBetween (Just "HEAD") upstreamHead + conflictsOnSync <- + if Seq.null remoteCommits + then pure [] + else gitConflictsWith (fromJust context.upstreamHead) + putStanzas - [ isSynchronizedStanza (Text.Builder.fromText branch) pushResult, - Seq1.fromSeq remoteCommits <&> \commits -> - syncStanza - Sync - { commits, - result = SyncResult'Failure, - source = upstream, - target = branch - }, - Seq1.fromSeq localCommits <&> \commits -> - syncStanza - Sync - { commits, - result = pushResultToSyncResult pushResult, - source = branch, - target = upstream - }, - case pushResult of - PushNotAttempted (ForkedHistory (List1.nonEmpty -> Just conflicts)) -> - conflictsStanza - ("These files will be in conflict when you run " <> Text.Builder.bold (Text.Builder.blue "mit sync") <> ":") - conflicts - _ -> Nothing, - whatNextStanza (Text.Builder.fromText branch) pushResult, + [ 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 undos) && committed then Just canUndoStanza else Nothing + if not (null state.undos) && committed then canUndoStanza else Nothing ] mitCommitMerge :: IO () mitCommitMerge = do - branch <- gitCurrentBranch - let branch64 = Text.encodeBase64 branch - head <- gitHead - state0 <- readMitState branch64 + context <- getContext -- Make the merge commit. Commonly we'll have gotten here by `mit merge `, so we'll have a `state0.merging` -- that tells us we're merging in . But we also handle the case that we went `git merge` -> `mit commit`, -- because why not. - case state0.merging of + case context.state.merging of Nothing -> git_ ["commit", "--all", "--no-edit"] Just merging -> - let message = fold ["⅄ ", if merging == branch then "" else merging <> " → ", branch] + let message = fold ["⅄ ", if merging == context.branch then "" else merging <> " → ", context.branch] in git_ ["commit", "--all", "--message", message] - writeMitState branch64 state0 {merging = Nothing, ranCommitAt = Nothing} + writeMitState context.branch context.state {merging = Nothing} let stanza0 = do - merging <- state0.merging - guard (merging /= branch) - synchronizedStanza (Text.Builder.fromText branch) (Text.Builder.fromText merging) + merging <- context.state.merging + guard (merging /= context.branch) + synchronizedStanza context.branch merging -- Three possible cases: -- 1. We had a dirty working directory before `mit merge` (evidence: our undo has a `git stash apply` in it) @@ -323,22 +286,23 @@ -- double conflict markers -- 2. We had a clean working directory before `mit merge`, so proceed to sync - case undosStash state0.undos of - Nothing -> mitSyncWith stanza0 (Just [Reset head]) + case undosStash context.state.undos of + Nothing -> mitSyncWith stanza0 (Just [Reset context.snapshot.head]) Just stash -> do conflicts <- gitApplyStash stash case List1.nonEmpty conflicts of -- FIXME we just unstashed, now we're about to stash again :/ - Nothing -> mitSyncWith stanza0 (Just [Reset head, Apply stash]) + 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 (Text.Builder.fromText branch) (PushNotAttempted MergeConflicts), - if null state0.undos then Nothing else Just canUndoStanza + whatNextStanza context.branch (PushNotAttempted MergeConflicts), + if null context.state.undos then Nothing else canUndoStanza ] +-- FIXME delete data PushResult = PushAttempted Bool | PushNotAttempted PushNotAttemptedReason @@ -350,157 +314,130 @@ | Offline -- fetch failed, so we seem offline | UnseenCommits -- we just pulled remote commits; don't push in case there's something local to address -pushResultToSyncResult :: PushResult -> SyncResult -pushResultToSyncResult = \case - PushAttempted False -> SyncResult'Failure - PushAttempted True -> SyncResult'Success - PushNotAttempted (ForkedHistory _) -> SyncResult'Failure - PushNotAttempted MergeConflicts -> SyncResult'Failure - PushNotAttempted NothingToPush -> SyncResult'Success -- doesnt matter, wont be shown - PushNotAttempted Offline -> SyncResult'Offline - PushNotAttempted UnseenCommits -> SyncResult'Pending - --- FIXME if on branch 'foo', handle 'mitMerge foo' or 'mitMerge origin/foo' as 'mitSync'? mitMerge :: Text -> IO () mitMerge target = do dieIfNotInGitDir dieIfMergeInProgress whenM gitExistUntrackedFiles dieIfBuggyGit - branch <- gitCurrentBranch - let branch64 = Text.encodeBase64 branch + context <- getContext + let upstream = "origin/" <> context.branch - -- When given 'mit merge foo', prefer merging 'origin/foo' over 'foo' - targetCommit <- do - _fetched <- gitFetch "origin" - gitRemoteBranchHead "origin" target & onNothingM (git ["rev-parse", target] & onLeftM \_ -> exitFailure) + if target == context.branch || target == upstream + then -- If on branch `foo`, treat `mit merge foo` and `mit merge origin/foo` as `mit sync` + mitSyncWith Nothing Nothing + else mitMergeWith context target - maybeMergeStatus <- mitMerge' ("⅄ " <> target <> " → " <> branch) targetCommit +mitMergeWith :: Context -> Text -> IO () +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) - let maybeMergeResult = (.result) <$> maybeMergeStatus + let upstream = "origin/" <> context.branch - let conflicts = - case maybeMergeResult of - Nothing -> [] - Just (MergeResult'MergeConflicts conflicts1) -> List1.toList conflicts1 - Just (MergeResult'StashConflicts conflicts1) -> List1.toList conflicts1 - Just MergeResult'Success -> [] + existRemoteCommits <- contextExistRemoteCommits context + existLocalCommits <- contextExistLocalCommits context - writeMitState - branch64 - MitState - { head = (), - merging = do - result <- maybeMergeResult - if mergeResultCommitted result - then Nothing - else Just target, - ranCommitAt = Nothing, - undos = - case maybeMergeStatus of - Nothing -> [] - Just mergeStatus -> List1.toList mergeStatus.undos - } + when (existRemoteCommits && not existLocalCommits) do + putStanzas $ + [ notSynchronizedStanza context.branch upstream ".", + runSyncStanza "Run" context.branch upstream + ] + exitFailure - let branchb = Text.Builder.fromText branch - let targetb = Text.Builder.fromText target + whenJust context.snapshot.stash \_stash -> + Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD") + merge <- performMerge ("⅄ " <> target <> " → " <> context.branch) targetCommit + + stashConflicts <- + if null merge.conflicts + then case context.snapshot.stash of + Nothing -> pure [] + Just stash -> gitApplyStash stash + else pure [] + + -- THIS IS NEW + push <- performPush context.branch + + let state = + MitState + { head = (), + merging = + if null merge.conflicts + then Nothing + else Just target, + undos = + if pushPushed push || Seq.null merge.commits + then [] + else undoToSnapshot context.snapshot + } + + writeMitState context.branch state + + remoteCommits <- + case context.upstreamHead of + Nothing -> pure Seq.empty + Just upstreamHead -> gitCommitsBetween (Just "HEAD") upstreamHead + + conflictsOnSync <- + if Seq.null remoteCommits + then pure [] + else gitConflictsWith (fromJust context.upstreamHead) + putStanzas - [ case maybeMergeResult of - Nothing -> synchronizedStanza branchb targetb - Just result -> - if mergeResultCommitted result - then synchronizedStanza branchb targetb - else notSynchronizedStanza branchb targetb ".", - maybeMergeStatus <&> \mergeStatus -> + [ if null merge.conflicts + then synchronizedStanza context.branch target + else notSynchronizedStanza context.branch target ".", + do + commits1 <- Seq1.fromSeq merge.commits syncStanza Sync - { commits = mergeStatus.commits, - result = if mergeResultCommitted mergeStatus.result then SyncResult'Success else SyncResult'Failure, + { commits = commits1, + success = null merge.conflicts, source = target, - target = branch + target = context.branch }, + isSynchronizedStanza2 context.branch push.what, do - result <- maybeMergeResult - if mergeResultCommitted result - then isSynchronizedStanza branchb (PushNotAttempted UnseenCommits) - else Nothing, + commits <- Seq1.fromSeq remoteCommits + syncStanza Sync {commits, success = False, source = upstream, target = context.branch}, + -- TODO show commits to remote do - conflicts1 <- List1.nonEmpty conflicts + conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts conflictsStanza "These files are in conflict:" conflicts1, - do - result <- maybeMergeResult - whatNextStanza - branchb - ( case result of - MergeResult'MergeConflicts _ -> PushNotAttempted MergeConflicts - MergeResult'StashConflicts _ -> PushNotAttempted UnseenCommits - MergeResult'Success -> PushNotAttempted UnseenCommits - ), - if isJust maybeMergeStatus then Just canUndoStanza else Nothing + -- 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 ] -data MergeStatus = MergeStatus - { commits :: Seq1 GitCommitInfo, - result :: MergeResult, - undos :: List1 Undo - } - -data MergeResult - = MergeResult'MergeConflicts (List1 GitConflict) - | MergeResult'StashConflicts (List1 GitConflict) - | MergeResult'Success - --- | Did this merge commit (possibly leaving behind a conflicting unstash)? -mergeResultCommitted :: MergeResult -> Bool -mergeResultCommitted = \case - MergeResult'MergeConflicts _ -> False - MergeResult'StashConflicts _ -> True - MergeResult'Success -> True - -mitMerge' :: Text -> Text -> IO (Maybe MergeStatus) -mitMerge' message target = do - head <- gitHead - (Seq1.fromSeq <$> gitCommitsBetween (Just head) target) >>= \case - Nothing -> pure Nothing - Just commits -> do - maybeStash <- gitStash - let undos = Reset head :| maybeToList (Apply <$> maybeStash) - result <- - 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]) - maybeConflicts <- for maybeStash gitApplyStash - pure - ( fromMaybe MergeResult'Success do - conflicts <- maybeConflicts - conflicts1 <- List1.nonEmpty conflicts - pure (MergeResult'StashConflicts conflicts1) - ) - pure (Just MergeStatus {commits, result, undos}) - -- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream mitSync :: IO () mitSync = do @@ -529,98 +466,101 @@ -- -- 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 :: Maybe Text.Builder -> Maybe [Undo] -> IO () +mitSyncWith :: Stanza -> Maybe [Undo] -> IO () mitSyncWith stanza0 maybeUndos = do - fetched <- gitFetch "origin" - branch <- gitCurrentBranch - let upstream = "origin/" <> branch - maybeUpstreamHead <- gitRemoteBranchHead "origin" branch - - maybeMergeStatus <- - case maybeUpstreamHead of - Nothing -> pure Nothing - Just upstreamHead -> mitMerge' ("⅄ " <> branch) upstreamHead - - let maybeMergeResult = (.result) <$> maybeMergeStatus + context <- getContext + let upstream = "origin/" <> context.branch - let conflicts = - case maybeMergeResult of - Nothing -> [] - Just (MergeResult'MergeConflicts conflicts1) -> List1.toList conflicts1 - Just (MergeResult'StashConflicts conflicts1) -> List1.toList conflicts1 - Just MergeResult'Success -> [] + whenJust context.snapshot.stash \_stash -> + Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD") - localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD" + merge <- + case context.upstreamHead of + -- Yay: no upstream branch is not different from an up-to-date local branch + Nothing -> pure GitMerge {commits = Seq.empty, conflicts = []} + Just upstreamHead -> performMerge ("⅄ " <> context.branch) upstreamHead - pushResult <- - case (localCommits, maybeMergeResult, fetched) of - (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush) - (Seq.NonEmpty, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted MergeConflicts) - (Seq.NonEmpty, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits) - (Seq.NonEmpty, Just MergeResult'Success, _) -> pure (PushNotAttempted UnseenCommits) - (Seq.NonEmpty, Nothing, False) -> pure (PushNotAttempted Offline) - (Seq.NonEmpty, Nothing, True) -> PushAttempted <$> gitPush branch + stashConflicts <- + if null merge.conflicts + then case context.snapshot.stash of + Nothing -> pure [] + Just stash -> gitApplyStash stash + else pure [] - let pushed = - case pushResult of - PushAttempted success -> success - PushNotAttempted _ -> False + push <- performPush context.branch - let undos = - case pushed of - False -> fromMaybe (maybe [] (List1.toList . (.undos)) maybeMergeStatus) maybeUndos - True -> [] + let state = + MitState + { head = (), + merging = + if null merge.conflicts + then Nothing + else Just context.branch, + undos = + if pushPushed push + then [] + else case maybeUndos of + Nothing -> + if Seq.null merge.commits + then [] + else undoToSnapshot context.snapshot + -- FIXME hm, could consider appending those undos instead, even if they obviate the recent stash/merge + -- undos + Just undos' -> undos' + } - writeMitState - (Text.encodeBase64 branch) - MitState - { head = (), - merging = do - result <- maybeMergeResult - if mergeResultCommitted result - then Nothing - else Just branch, - ranCommitAt = Nothing, - undos - } + writeMitState context.branch state putStanzas [ stanza0, - isSynchronizedStanza (Text.Builder.fromText branch) pushResult, - maybeMergeStatus <&> \mergeStatus -> + isSynchronizedStanza2 context.branch push.what, + do + commits1 <- Seq1.fromSeq merge.commits syncStanza Sync - { commits = mergeStatus.commits, - result = if mergeResultCommitted mergeStatus.result then SyncResult'Success else SyncResult'Failure, + { commits = commits1, + success = null merge.conflicts, source = upstream, - target = branch + target = context.branch }, - Seq1.fromSeq localCommits <&> \commits -> + do + commits <- Seq1.fromSeq push.commits syncStanza Sync { commits, - result = pushResultToSyncResult pushResult, - source = branch, + success = pushPushed push, + source = context.branch, target = upstream }, do - conflicts1 <- List1.nonEmpty conflicts + conflicts1 <- List1.nonEmpty merge.conflicts <|> List1.nonEmpty stashConflicts conflictsStanza "These files are in conflict:" conflicts1, - whatNextStanza (Text.Builder.fromText branch) pushResult, - if not (null undos) then Just canUndoStanza else Nothing + 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 ] -- FIXME output what we just undid mitUndo :: IO () mitUndo = do dieIfNotInGitDir - - branch64 <- Text.encodeBase64 <$> gitCurrentBranch - state0 <- readMitState branch64 - case List1.nonEmpty state0.undos of + context <- getContext + case List1.nonEmpty context.state.undos of Nothing -> exitFailure Just undos1 -> for_ undos1 applyUndo - when (undosContainRevert state0.undos) mitSync + when (undosContainRevert context.state.undos) mitSync where undosContainRevert :: [Undo] -> Bool undosContainRevert = \case @@ -628,25 +568,19 @@ Revert _ : _ -> True _ : undos -> undosContainRevert undos +-- FIXME this type kinda sux now, replace with GitMerge probably? data Sync = Sync { commits :: Seq1 GitCommitInfo, - result :: SyncResult, + success :: Bool, source :: Text, target :: Text } -data SyncResult - = SyncResult'Failure - | SyncResult'Offline - | SyncResult'Pending - | SyncResult'Success - deriving stock (Eq) - -canUndoStanza :: Text.Builder +canUndoStanza :: Stanza canUndoStanza = - " Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change." + Just (" Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change.") -conflictsStanza :: Text.Builder -> List1 GitConflict -> Maybe Text.Builder +conflictsStanza :: Text.Builder -> List1 GitConflict -> Stanza conflictsStanza prefix conflicts = Just $ " " @@ -654,43 +588,58 @@ <> Builder.newline <> Builder.vcat ((\conflict -> " " <> Text.Builder.red (showGitConflict conflict)) <$> conflicts) -isSynchronizedStanza :: Text.Builder -> PushResult -> Maybe Text.Builder -isSynchronizedStanza branch = \case - PushAttempted False -> - notSynchronizedStanza branch upstream (" because " <> Text.Builder.bold "git push" <> " failed.") - PushAttempted True -> synchronizedStanza branch upstream - PushNotAttempted MergeConflicts -> - notSynchronizedStanza branch upstream " because you have local conflicts to resolve." - PushNotAttempted (ForkedHistory _) -> notSynchronizedStanza branch upstream "; their commit histories have diverged." - PushNotAttempted NothingToPush -> synchronizedStanza branch upstream - PushNotAttempted Offline -> notSynchronizedStanza branch upstream " because you appear to be offline." - PushNotAttempted UnseenCommits -> notSynchronizedStanza branch upstream "." +isSynchronizedStanza2 :: Text -> GitPushWhat -> Stanza +isSynchronizedStanza2 branch = \case + NothingToPush2 -> synchronizedStanza branch upstream + 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.") where upstream = "origin/" <> branch -notSynchronizedStanza :: Text.Builder -> Text.Builder -> Text.Builder -> Maybe Text.Builder +notSynchronizedStanza :: Text -> Text -> Text.Builder -> Stanza notSynchronizedStanza branch other suffix = - Just - ( " " - <> Text.Builder.red - ( Text.Builder.italic branch - <> " is not synchronized with " - <> Text.Builder.italic other - <> suffix - ) - ) + Just (" " <> Text.Builder.red (branchb branch <> " is not synchronized with " <> branchb other <> suffix)) -whatNextStanza :: Text.Builder -> PushResult -> Maybe Text.Builder +runSyncStanza :: Text.Builder -> Text -> Text -> Stanza +runSyncStanza prefix branch upstream = + Just $ + " " + <> prefix + <> " " + <> Text.Builder.bold (Text.Builder.blue "mit sync") + <> " to synchronize " + <> branchb branch + <> " with " + <> branchb upstream + <> "." + +syncStanza :: Sync -> Stanza +syncStanza sync = + Just $ + Text.Builder.italic + (colorize (" " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)) + <> "\n" + <> (Builder.vcat ((\commit -> " " <> prettyGitCommitInfo commit) <$> commits')) + <> (if more then " ..." else Builder.empty) + where + colorize :: Text.Builder -> Text.Builder + colorize = + if sync.success then Text.Builder.green else Text.Builder.red + (commits', more) = + case Seq1.length sync.commits > 10 of + False -> (Seq1.toSeq sync.commits, False) + True -> (Seq1.dropEnd 1 sync.commits, True) + +synchronizedStanza :: Text -> Text -> Stanza +synchronizedStanza branch other = + Just (" " <> Text.Builder.green (branchb branch <> " is synchronized with " <> branchb other <> ".")) + +-- FIXME remove +whatNextStanza :: Text -> PushResult -> Stanza whatNextStanza branch = \case - PushAttempted False -> - Just $ - " Run " - <> sync - <> " to synchronize " - <> Text.Builder.italic branch - <> " with " - <> Text.Builder.italic upstream - <> "." + PushAttempted False -> runSyncStanza "Run" branch upstream PushAttempted True -> Nothing PushNotAttempted (ForkedHistory conflicts) -> Just $ @@ -701,9 +650,9 @@ <> ", examine the repository, then run " <> sync <> " again to synchronize " - <> Text.Builder.italic branch + <> branchb branch <> " with " - <> Text.Builder.italic upstream + <> branchb upstream <> "." else " Run " @@ -711,71 +660,163 @@ <> ", resolve the conflicts, then run " <> commit <> " to synchronize " - <> Text.Builder.italic branch + <> branchb branch <> " with " - <> Text.Builder.italic upstream + <> branchb upstream <> "." PushNotAttempted MergeConflicts -> Just (" Resolve the merge conflicts, then run " <> commit <> ".") PushNotAttempted NothingToPush -> Nothing - PushNotAttempted Offline -> - Just $ - " When you come online, run " - <> sync - <> " to synchronize " - <> Text.Builder.italic branch - <> " with " - <> Text.Builder.italic upstream - <> "." - PushNotAttempted UnseenCommits -> - Just $ - " Examine the repository, then run " - <> sync - <> " to synchronize " - <> Text.Builder.italic branch - <> " with " - <> Text.Builder.italic upstream - <> "." + 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") upstream = "origin/" <> branch -syncStanza :: Sync -> Text.Builder -syncStanza sync = - Text.Builder.italic - (colorize (" " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)) - <> "\n" - <> (Builder.vcat ((\commit -> " " <> prettyGitCommitInfo commit) <$> commits')) - <> (if more then " ..." else Builder.empty) - where - colorize :: Text.Builder -> Text.Builder - colorize = - case sync.result of - 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) +branchb :: Text -> Text.Builder +branchb = + Text.Builder.italic . Text.Builder.fromText -synchronizedStanza :: Text.Builder -> Text.Builder -> Maybe Text.Builder -synchronizedStanza branch other = - Just - ( " " - <> Text.Builder.green - (Text.Builder.italic branch <> " is synchronized with " <> Text.Builder.italic other <> ".") - ) +------------------------------------------------------------------------------------------------------------------------ +-- Context -renderStanzas :: [Maybe Text.Builder] -> Maybe Text.Builder -renderStanzas stanzas = - case catMaybes stanzas of - [] -> Nothing - stanzas' -> Just (mconcat (List.intersperse (Builder.newline <> Builder.newline) stanzas')) +data Context = Context + { branch :: Text, + snapshot :: GitSnapshot, + state :: MitState (), + upstreamHead :: Maybe Text + } -putStanzas :: [Maybe Text.Builder] -> IO () -putStanzas stanzas = - whenJust (renderStanzas stanzas) \s -> - Text.putStr (Builder.build (Builder.newline <> s <> Builder.newline <> Builder.newline)) +getContext :: IO Context +getContext = do + gitFetch_ "origin" + branch <- Git.git Git.BranchShowCurrent + upstreamHead <- gitRemoteBranchHead "origin" branch + state <- readMitState branch + snapshot <- performSnapshot + pure Context {branch, snapshot, state, upstreamHead} + +contextExistLocalCommits :: Context -> IO Bool +contextExistLocalCommits context = + case context.upstreamHead of + Nothing -> pure True + Just upstreamHead -> gitExistCommitsBetween upstreamHead context.snapshot.head + +contextExistRemoteCommits :: Context -> IO Bool +contextExistRemoteCommits context = + case context.upstreamHead of + Nothing -> pure False + Just upstreamHead -> gitExistCommitsBetween context.snapshot.head upstreamHead + +------------------------------------------------------------------------------------------------------------------------ +-- Git merge + +-- | The result of a @git merge@. +-- +-- Impossible case: Impossible case: empty list of commits, non-empty list of conflicts. +data GitMerge = GitMerge + { -- | The list of commits that were applied (or would be applied once conflicts are resolved), minus the merge commit + -- itself. + commits :: Seq GitCommitInfo, + conflicts :: [GitConflict] + } + +-- Perform a fast-forward-if-possible git merge, and return the commits that were applied (or *would be* applied) (minus +-- the merge commit), along with the conflicting files. Impossible case: empty list of commits, non-empty list of +-- conflicts. +-- +-- Precondition: the working directory is clean. TODO take unused GitStash as argument? +performMerge :: Text -> Text -> IO GitMerge +performMerge message commitish = do + head <- gitHead + commits <- gitCommitsBetween (Just head) commitish + conflicts <- + if Seq.null commits + then pure [] + else + git ["merge", "--ff", "--no-commit", commitish] >>= \case + False -> gitConflicts + True -> do + -- If this was a fast-forward, a merge would not be in progress at this point. + whenM gitMergeInProgress (git_ ["commit", "--message", message]) + pure [] + pure GitMerge {commits, conflicts} + +------------------------------------------------------------------------------------------------------------------------ +-- Git push + +data GitPush = GitPush + { commits :: Seq GitCommitInfo, + undo :: [Undo], + what :: GitPushWhat + } + +data GitPushWhat + = NothingToPush2 + | Pushed + | PushWouldntReachRemote + | PushWouldBeRejected + | TriedToPush + +pushPushed :: GitPush -> Bool +pushPushed push = + case push.what of + NothingToPush2 -> False + Pushed -> True + PushWouldntReachRemote -> False + PushWouldBeRejected -> False + TriedToPush -> False + +-- TODO get context +performPush :: Text -> IO GitPush +performPush branch = do + fetched <- gitFetch "origin" + head <- gitHead + upstreamHead <- gitRemoteBranchHead "origin" branch + commits <- gitCommitsBetween upstreamHead head + + if Seq.null commits + then pure GitPush {commits, undo = [], what = NothingToPush2} + else do + existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head) upstreamHead + if existRemoteCommits + then pure GitPush {commits, undo = [], what = PushWouldBeRejected} + else + if fetched + then + gitPush branch >>= \case + False -> pure GitPush {commits, undo = [], what = TriedToPush} + True -> do + undo <- + if Seq.length commits == 1 + then + gitIsMergeCommit head <&> \case + False -> [Revert head] + True -> [] + else pure [] + pure GitPush {commits, undo, what = Pushed} + else pure GitPush {commits, undo = [], what = PushWouldntReachRemote} + +------------------------------------------------------------------------------------------------------------------------ +-- Git snapshot + +data GitSnapshot = GitSnapshot + { head :: Text, + stash :: Maybe Text + } + +performSnapshot :: IO GitSnapshot +performSnapshot = do + head <- gitHead + stash <- + gitDiff >>= \case + Differences -> Just <$> gitCreateStash + NoDifferences -> pure Nothing + pure GitSnapshot {head, stash} + +undoToSnapshot :: GitSnapshot -> [Undo] +undoToSnapshot snapshot = + Reset snapshot.head : case snapshot.stash of + Nothing -> [] + Just stash -> [Apply stash] diff --git a/src/Mit/Builder.hs b/src/Mit/Builder.hs --- a/src/Mit/Builder.hs +++ b/src/Mit/Builder.hs @@ -11,9 +11,9 @@ ) where -import qualified Data.List as List -import qualified Data.Text.IO as Text -import qualified Data.Text.Lazy as Text.Lazy +import Data.List qualified as List +import Data.Text.IO qualified as Text +import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Builder import Mit.Prelude diff --git a/src/Mit/Clock.hs b/src/Mit/Clock.hs deleted file mode 100644 --- a/src/Mit/Clock.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Mit.Clock - ( getCurrentTime, - ) -where - -import Mit.Prelude -import qualified System.Clock as Clock - -getCurrentTime :: IO Word64 -getCurrentTime = do - Clock.TimeSpec {sec, nsec} <- Clock.getTime Clock.Realtime - pure (fromIntegral (1_000_000_000 * sec + nsec)) diff --git a/src/Mit/Directory.hs b/src/Mit/Directory.hs --- a/src/Mit/Directory.hs +++ b/src/Mit/Directory.hs @@ -1,8 +1,12 @@ -module Mit.Directory where +module Mit.Directory + ( doesDirectoryExist, + withCurrentDirectory, + ) +where -import qualified Data.Text as Text +import Data.Text qualified as Text import Mit.Prelude -import qualified System.Directory as Directory +import System.Directory qualified as Directory doesDirectoryExist :: Text -> IO Bool doesDirectoryExist = diff --git a/src/Mit/Git.hs b/src/Mit/Git.hs --- a/src/Mit/Git.hs +++ b/src/Mit/Git.hs @@ -1,15 +1,18 @@ +-- | High-level git operations 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.Builder.ANSI as Text.Builder -import qualified Data.Text.IO as Text -import qualified Data.Text.Lazy.Builder as Text (Builder) -import qualified Data.Text.Lazy.Builder as Text.Builder -import qualified Ki -import qualified Mit.Builder as Builder +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Data.Text.Builder.ANSI qualified as Text.Builder +import Data.Text.IO qualified as Text +import Data.Text.Lazy.Builder qualified as Text (Builder) +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.Prelude import Mit.Process import System.Directory (doesFileExist) @@ -22,6 +25,7 @@ import System.Posix.Terminal (queryTerminal) import System.Process import System.Process.Internals +import Text.Parsec qualified as Parsec gitdir :: Text gitdir = @@ -47,6 +51,12 @@ } deriving stock (Show) +parseGitCommitInfo :: Text -> GitCommitInfo +parseGitCommitInfo line = + case Text.split (== '\xFEFF') line of + [author, date, hash, shorthash, subject] -> GitCommitInfo {author, date, hash, shorthash, subject} + _ -> error (Text.unpack line) + prettyGitCommitInfo :: GitCommitInfo -> Text.Builder prettyGitCommitInfo info = fold @@ -56,13 +66,36 @@ " - ", Text.Builder.italic (Text.Builder.white (Text.Builder.fromText info.author)), Builder.space, - Text.Builder.italic (Text.Builder.yellow (Text.Builder.fromText 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 = GitConflict GitConflictXY Text deriving stock (Eq, Show) +-- FIXME +-- +-- 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 parseGitConflict :: Text -> Maybe GitConflict parseGitConflict line = do [xy, name] <- Just (Text.words line) @@ -115,26 +148,27 @@ gitApplyStash :: Text -> IO [GitConflict] gitApplyStash stash = do conflicts <- - git ["stash", "apply", "--quiet", stash] >>= \case + Git.git (Git.StashApply Git.FlagQuiet stash) >>= \case False -> gitConflicts True -> pure [] gitUnstageChanges pure conflicts -- | Create a branch. +-- FIXME inline this gitBranch :: Text -> IO () gitBranch branch = - git_ ["branch", "--no-track", branch] + Git.git (Git.Branch Git.FlagNoTrack branch) -- | Does the given local branch (refs/heads/...) exist? gitBranchExists :: Text -> IO Bool gitBranchExists branch = - git ["rev-parse", "--verify", "refs/heads/" <> 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 branch = - git ["rev-parse", "refs/heads/" <> branch] <&> \case + Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify ("refs/heads/" <> branch)) <&> \case Left _ -> Nothing Right head -> Just head @@ -172,22 +206,17 @@ "--max-count=11", maybe id (\c1 c2 -> c1 <> ".." <> c2) commit1 commit2 ] - pure (parseCommitInfo <$> dropEvens commits) + pure (parseGitCommitInfo <$> dropEvens commits) where -- git rev-list with a custom format prefixes every commit with a redundant line :| dropEvens :: Seq a -> Seq a dropEvens = \case _ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs xs -> xs - parseCommitInfo :: Text -> GitCommitInfo - parseCommitInfo line = - case Text.split (== '\xFEFF') line of - [author, date, hash, shorthash, subject] -> GitCommitInfo {author, date, hash, shorthash, subject} - _ -> error (Text.unpack line) gitConflicts :: IO [GitConflict] gitConflicts = - mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"] + mapMaybe parseGitConflict <$> Git.git (Git.StatusV1 Git.FlagNoRenames) -- | Get the conflicts with the given commitish. -- @@ -196,35 +225,31 @@ gitConflictsWith commit = do maybeStash <- gitStash conflicts <- - git ["merge", "--no-commit", "--no-ff", commit] >>= \case + Git.git (Git.Merge Git.FlagNoCommit Git.FlagNoFF commit) >>= \case False -> gitConflicts True -> pure [] - git_ ["merge", "--abort"] - whenJust maybeStash \stash -> git_ ["stash", "apply", "--quiet", stash] + whenM gitMergeInProgress (Git.git_ Git.MergeAbort) + whenJust maybeStash \stash -> Git.git (Git.StashApply Git.FlagQuiet stash) pure conflicts +-- | Precondition: there are changes to stash gitCreateStash :: IO Text gitCreateStash = do - git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed - stash <- git ["stash", "create"] + Git.git_ Git.AddAll -- it seems certain things (like renames), unless staged, cannot be stashed + stash <- Git.git Git.StashCreate gitUnstageChanges pure stash --- | Get the current branch. -gitCurrentBranch :: IO Text -gitCurrentBranch = - git ["branch", "--show-current"] - gitDefaultBranch :: Text -> IO Text gitDefaultBranch remote = do - ref <- git ["symbolic-ref", "refs/remotes/" <> remote <> "/HEAD"] + ref <- Git.git (Git.SymbolicRef ("refs/remotes/" <> remote <> "/HEAD")) pure (Text.drop (14 + Text.length remote) ref) -- FIXME document this gitDiff :: IO DiffResult gitDiff = do gitUnstageChanges - git ["diff", "--quiet"] <&> \case + Git.git (Git.Diff Git.FlagQuiet) <&> \case False -> Differences True -> NoDifferences @@ -240,17 +265,33 @@ not . null <$> gitListUntrackedFiles gitFetch :: Text -> IO Bool -gitFetch remote = - git ["fetch", remote] +gitFetch remote = do + fetched <- readIORef fetchedRef + case Map.lookup remote fetched of + Nothing -> do + success <- Git.git (Git.Fetch remote) + writeIORef fetchedRef (Map.insert remote success fetched) + pure success + Just success -> pure success +-- Only fetch each remote at most once per run of `mit` +fetchedRef :: IORef (Map Text Bool) +fetchedRef = + unsafePerformIO (newIORef mempty) +{-# NOINLINE fetchedRef #-} + gitFetch_ :: Text -> IO () gitFetch_ = void . gitFetch gitHead :: IO Text gitHead = - git ["rev-parse", "HEAD"] + Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify "HEAD") +gitIsMergeCommit :: Text -> IO Bool +gitIsMergeCommit commit = + Git.git (Git.RevParse Git.FlagQuiet Git.FlagVerify (commit <> "^2")) + -- | List all untracked files. gitListUntrackedFiles :: IO [Text] gitListUntrackedFiles = @@ -267,39 +308,42 @@ -- | Does the given remote branch (refs/remotes/...) exist? gitRemoteBranchExists :: Text -> Text -> IO Bool gitRemoteBranchExists remote branch = - git ["rev-parse", "--verify", "refs/remotes/" <> 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 remote branch = - git ["rev-parse", "refs/remotes/" <> remote <> "/" <> branch] <&> \case + Git.git (Git.RevParse Git.NoFlagQuiet Git.NoFlagVerify ("refs/remotes/" <> remote <> "/" <> branch)) <&> \case Left _ -> Nothing Right head -> Just head +gitShow :: Text -> IO GitCommitInfo +gitShow commit = + parseGitCommitInfo + <$> git + [ "show", + "--color=always", + "--date=human", + "--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s", + commit + ] + -- | Stash uncommitted changes (if any). gitStash :: IO (Maybe Text) gitStash = do gitDiff >>= \case Differences -> do stash <- gitCreateStash - git_ ["clean", "-d", "--force"] - git_ ["reset", "--hard", "HEAD"] + Git.git_ (Git.Clean Git.FlagD Git.FlagForce) + Git.git_ (Git.Reset Git.Hard Git.FlagQuiet "HEAD") pure (Just stash) NoDifferences -> pure Nothing -gitSwitch :: Text -> IO Bool -gitSwitch branch = - git ["switch", branch] - -gitSwitch_ :: Text -> IO () -gitSwitch_ branch = - git_ ["switch", branch] - gitUnstageChanges :: IO () gitUnstageChanges = do - git_ ["reset", "--mixed", "--quiet"] + Git.git_ (Git.ResetPaths Git.FlagQuiet ["."]) untrackedFiles <- gitListUntrackedFiles - unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles)) + unless (null untrackedFiles) (Git.git_ (Git.Add Git.FlagIntentToAdd untrackedFiles)) gitVersion :: IO GitVersion gitVersion = do @@ -315,25 +359,44 @@ data GitWorktree = GitWorktree { branch :: Maybe Text, commit :: Text, - directory :: Text + directory :: Text, + prunable :: Bool } -- /dir/one 0efd393c35 [oingo] -> ("/dir/one", "0efd393c35", Just "oingo") -- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing) gitWorktreeList :: IO [GitWorktree] gitWorktreeList = do - map f <$> git ["worktree", "list"] + git ["worktree", "list"] <&> map \line -> + case Parsec.parse parser "" line of + Left err -> error (show err) + Right worktree -> worktree where - f :: Text -> GitWorktree - f line = - case Text.words line of - [directory, commit, stripBrackets -> Just branch] -> GitWorktree {branch = Just branch, commit, directory} - [directory, commit, "(detached", "HEAD)"] -> GitWorktree {branch = Nothing, commit, directory} - _ -> error (Text.unpack line) + parser :: Parsec.Parsec Text () GitWorktree + parser = do + directory <- segmentP + Parsec.spaces + commit <- segmentP + Parsec.spaces + branch <- + asum + [ Nothing <$ Parsec.string "(detached HEAD)", + fmap Just do + _ <- Parsec.char '[' + branch <- Parsec.manyTill Parsec.anyChar (Parsec.char ']') + pure (Text.pack branch) + ] + Parsec.spaces + prunable <- + asum + [ True <$ Parsec.string "prunable", + pure False + ] + pure GitWorktree {branch, commit, directory, prunable} where - stripBrackets :: Text -> Maybe Text - stripBrackets = - Text.stripPrefix "[" >=> Text.stripSuffix "]" + segmentP :: Parsec.Parsec Text () Text + segmentP = + Text.pack <$> Parsec.many1 (Parsec.satisfy (not . isSpace)) -- git@github.com:mitchellwrosen/mit.git -> Just ("git@github.com:mitchellwrosen/mit.git", "mit") parseGitRepo :: Text -> Maybe (Text, Text) diff --git a/src/Mit/GitCommand.hs b/src/Mit/GitCommand.hs new file mode 100644 --- /dev/null +++ b/src/Mit/GitCommand.hs @@ -0,0 +1,260 @@ +-- | Low-level git commands +module Mit.GitCommand + ( Command (..), + ResetMode (..), + FlagD (..), + FlagForce (..), + FlagIntentToAdd (..), + FlagNoCommit (..), + FlagNoFF (..), + FlagNoRenames (..), + FlagNoTrack (..), + FlagQuiet (..), + FlagVerify (..), + git, + git_, + ) +where + +import Data.Sequence qualified as Seq +import Data.Text qualified as Text +import Data.Text.Builder.ANSI qualified as Text.Builder +import Data.Text.IO qualified as Text +import Data.Text.Lazy.Builder qualified as Text (Builder) +import Data.Text.Lazy.Builder qualified as Text.Builder +import Ki qualified +import Mit.Builder qualified as Builder +import Mit.Config (verbose) +import Mit.Prelude +import Mit.Process +import System.Exit (ExitCode (..)) +import System.IO (Handle, hClose, hIsEOF) +import System.Posix.Process (getProcessGroupIDOf) +import System.Posix.Signals +import System.Process +import System.Process.Internals + +data Command + = AddAll + | Add FlagIntentToAdd [Text] + | Branch FlagNoTrack Text + | BranchSetUpstreamTo Text + | BranchShowCurrent + | Clean FlagD FlagForce + | Diff FlagQuiet + | Fetch Text + | Merge FlagNoCommit FlagNoFF Text + | MergeAbort + | Reset ResetMode FlagQuiet Text + | ResetPaths FlagQuiet [Text] + | RevParse FlagQuiet FlagVerify Text + | StashApply FlagQuiet Text + | StashCreate + | StatusV1 FlagNoRenames + | Switch Text + | SymbolicRef Text + +renderCommand :: Command -> [Text] +renderCommand = \case + Add intentToAdd files -> ["add"] ++ renderFlagIntentToAdd intentToAdd ++ files + AddAll -> ["add", "--all"] + Branch noTrack branch -> ["branch"] ++ renderFlagNoTrack noTrack ++ [branch] + BranchSetUpstreamTo upstream -> ["branch", "--set-upstream-to", upstream] + BranchShowCurrent -> ["branch", "--show-current"] + Clean d force -> ["clean"] ++ renderFlagD d ++ renderFlagForce force + Diff quiet -> ["diff"] ++ renderFlagQuiet quiet + Fetch remote -> ["fetch", remote] + Merge noCommit noFF commit -> ["merge"] ++ renderFlagNoCommit noCommit ++ renderFlagNoFF noFF ++ [commit] + MergeAbort -> ["merge", "--abort"] + Reset mode quiet commit -> ["reset", renderResetMode mode] ++ renderFlagQuiet quiet ++ [commit] + ResetPaths quiet paths -> ["reset"] ++ renderFlagQuiet quiet ++ ["--"] ++ paths + RevParse quiet verify commit -> ["rev-parse"] ++ renderFlagQuiet quiet ++ renderFlagVerify verify ++ [commit] + StashApply quiet commit -> ["stash", "apply"] ++ renderFlagQuiet quiet ++ [commit] + StashCreate -> ["stash", "create"] + StatusV1 noRenames -> ["status"] ++ renderFlagNoRenames noRenames ++ ["--porcelain=v1"] + Switch branch -> ["switch", branch] + SymbolicRef commit -> ["symbolic-ref", commit] + +data ResetMode + = Mixed + | Hard + +renderResetMode :: ResetMode -> Text +renderResetMode = \case + Mixed -> "--mixed" + Hard -> "--hard" + +data FlagD + = FlagD + | NoFlagD + +renderFlagD :: FlagD -> [Text] +renderFlagD = \case + FlagD -> ["-d"] + NoFlagD -> [] + +data FlagForce + = FlagForce + | NoFlagForce + +renderFlagForce :: FlagForce -> [Text] +renderFlagForce = \case + FlagForce -> ["--force"] + NoFlagForce -> [] + +data FlagIntentToAdd + = FlagIntentToAdd + | NoFlagIntentToAdd + +renderFlagIntentToAdd :: FlagIntentToAdd -> [Text] +renderFlagIntentToAdd = \case + FlagIntentToAdd -> ["--intent-to-add"] + NoFlagIntentToAdd -> [] + +data FlagNoCommit + = FlagNoCommit + | NoFlagNoCommit + +renderFlagNoCommit :: FlagNoCommit -> [Text] +renderFlagNoCommit = \case + FlagNoCommit -> ["--no-commit"] + NoFlagNoCommit -> [] + +data FlagNoFF + = FlagNoFF + | NoFlagNoFF + +renderFlagNoFF :: FlagNoFF -> [Text] +renderFlagNoFF = \case + FlagNoFF -> ["--no-ff"] + NoFlagNoFF -> [] + +data FlagNoRenames + = FlagNoRenames + | NoFlagNoRenames + +renderFlagNoRenames :: FlagNoRenames -> [Text] +renderFlagNoRenames = \case + FlagNoRenames -> ["--no-renames"] + NoFlagNoRenames -> [] + +data FlagNoTrack + = FlagNoTrack + | NoFlagNoTrack + +renderFlagNoTrack :: FlagNoTrack -> [Text] +renderFlagNoTrack = \case + FlagNoTrack -> ["--no-track"] + NoFlagNoTrack -> [] + +data FlagQuiet + = FlagQuiet + | NoFlagQuiet + +renderFlagQuiet :: FlagQuiet -> [Text] +renderFlagQuiet = \case + FlagQuiet -> ["--quiet"] + NoFlagQuiet -> [] + +data FlagVerify + = FlagVerify + | NoFlagVerify + +renderFlagVerify :: FlagVerify -> [Text] +renderFlagVerify = \case + FlagVerify -> ["--verify"] + NoFlagVerify -> [] + +------------------------------------------------------------------------------------------------------------------------ +-- Git process stuff + +git :: ProcessOutput a => Command -> IO a +git = + runGit . renderCommand + +git_ :: Command -> IO () +git_ = + git + +runGit :: ProcessOutput a => [Text] -> IO a +runGit args = do + 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 + +debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO () +debugPrintGit args stdoutLines stderrLines exitCode = + case verbose of + 1 -> Builder.putln (Text.Builder.brightBlack v1) + 2 -> Builder.putln (Text.Builder.brightBlack (v1 <> v2)) + _ -> pure () + where + v1 = Text.Builder.bold (marker <> " git " <> Builder.hcat (map quote args)) + v2 = foldMap (\line -> "\n " <> Text.Builder.fromText line) (stdoutLines <> stderrLines) + + quote :: Text -> Text.Builder + quote s = + if Text.any isSpace s + then Builder.squoted (Text.Builder.fromText (Text.replace "'" "\\'" s)) + else Text.Builder.fromText s + + marker :: Text.Builder + marker = + case exitCode of + ExitFailure _ -> Text.Builder.singleton '✗' + ExitSuccess -> Text.Builder.singleton '✓' + +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 @@ -4,20 +4,25 @@ ) where +import Control.Applicative as X ((<|>)) import Control.Category as X hiding (id, (.)) import Control.Exception as X hiding (handle) import Control.Monad as X import Data.Char as X import Data.Foldable as X import Data.Function as X -import qualified Data.List.NonEmpty as List1 +import Data.IORef as X +import Data.List.NonEmpty qualified as List1 +import Data.Map as X (Map) import Data.Maybe as X import Data.Sequence as X (Seq) +import Data.Set as X (Set) import Data.Text as X (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import Data.Text qualified as Text +import Data.Text.IO qualified as Text import Data.Traversable as X import Data.Word as X (Word64) +import GHC.Stack as X (HasCallStack) import Mit.Seq1 as X (Seq1) import Text.Read as X (readMaybe) import Prelude as X hiding (head, id) diff --git a/src/Mit/Process.hs b/src/Mit/Process.hs --- a/src/Mit/Process.hs +++ b/src/Mit/Process.hs @@ -1,8 +1,11 @@ -- Some ad-hoc process return value overloading, for cleaner syntax -module Mit.Process where +module Mit.Process + ( ProcessOutput (..), + ) +where -import qualified Data.Sequence as Seq +import Data.Sequence qualified as Seq import Mit.Prelude import System.Exit (ExitCode (..), exitWith) diff --git a/src/Mit/Seq.hs b/src/Mit/Seq.hs --- a/src/Mit/Seq.hs +++ b/src/Mit/Seq.hs @@ -1,6 +1,11 @@ -module Mit.Seq where +module Mit.Seq + ( pattern NonEmpty, + pattern Singleton, + toList, + ) +where -import qualified Data.Foldable as Foldable +import Data.Foldable qualified as Foldable import Data.Sequence pattern NonEmpty :: Seq a diff --git a/src/Mit/Seq1.hs b/src/Mit/Seq1.hs --- a/src/Mit/Seq1.hs +++ b/src/Mit/Seq1.hs @@ -1,38 +1,53 @@ -module Mit.Seq1 where +module Mit.Seq1 + ( Seq1, + fromSeq, + unsafeFromSeq, + toSeq, + toList, + Mit.Seq1.length, + dropEnd, + ) +where import Data.Coerce -import qualified Data.Foldable +import Data.Foldable qualified +import Data.Maybe (fromMaybe) import Data.Sequence (Seq) -import qualified Data.Sequence as Seq +import Data.Sequence qualified as Seq +import GHC.Stack (HasCallStack) import Prelude -newtype Seq1 a = Seq1 - {unSeq1 :: Seq a} +newtype Seq1 a = Seq1 (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) +unsafeFromSeq :: HasCallStack => Seq a -> Seq1 a +unsafeFromSeq = + fromMaybe (error "unsafeFromSeq: empty sequence") . fromSeq +toSeq :: Seq1 a -> Seq a +toSeq = + coerce + toList :: forall a. Seq1 a -> [a] toList = coerce (Data.Foldable.toList @Seq @a) -toSeq :: Seq1 a -> Seq a -toSeq = - coerce +length :: forall a. Seq1 a -> Int +length = + coerce (Seq.length @a) + +dropEnd :: Int -> Seq1 a -> Seq a +dropEnd = + let loop :: Int -> Seq a -> Seq a + 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 diff --git a/src/Mit/Stanza.hs b/src/Mit/Stanza.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Stanza.hs @@ -0,0 +1,26 @@ +module Mit.Stanza + ( Stanza, + renderStanzas, + putStanzas, + ) +where + +import Data.List qualified as List +import Data.Text.IO qualified as Text +import Data.Text.Lazy.Builder qualified as Text (Builder) +import Mit.Builder qualified as Builder +import Mit.Prelude + +type Stanza = + Maybe Text.Builder + +renderStanzas :: [Stanza] -> Stanza +renderStanzas stanzas = + case catMaybes stanzas of + [] -> Nothing + stanzas' -> Just (mconcat (List.intersperse (Builder.newline <> Builder.newline) stanzas')) + +putStanzas :: [Stanza] -> IO () +putStanzas stanzas = + whenJust (renderStanzas stanzas) \s -> + Text.putStr (Builder.build (Builder.newline <> s <> Builder.newline <> Builder.newline)) diff --git a/src/Mit/State.hs b/src/Mit/State.hs --- a/src/Mit/State.hs +++ b/src/Mit/State.hs @@ -1,8 +1,15 @@ -module Mit.State where +module Mit.State + ( MitState (..), + emptyMitState, + deleteMitState, + readMitState, + writeMitState, + ) +where -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Mit.Clock (getCurrentTime) +import Data.Text qualified as Text +import Data.Text.Encoding.Base64 qualified as Text +import Data.Text.IO qualified as Text import Mit.Git import Mit.Prelude import Mit.Undo @@ -11,14 +18,13 @@ data MitState a = MitState { head :: a, merging :: Maybe Text, - ranCommitAt :: Maybe Word64, undos :: [Undo] } deriving stock (Eq, Show) emptyMitState :: MitState () emptyMitState = - MitState {head = (), merging = Nothing, ranCommitAt = Nothing, undos = []} + MitState {head = (), merging = Nothing, undos = []} deleteMitState :: Text -> IO () deleteMitState branch64 = @@ -26,23 +32,18 @@ parseMitState :: Text -> Maybe (MitState Text) parseMitState contents = do - [headLine, mergingLine, ranCommitAtLine, undosLine] <- Just (Text.lines contents) + [headLine, mergingLine, undosLine] <- Just (Text.lines contents) ["head", head] <- Just (Text.words headLine) merging <- case Text.words mergingLine of ["merging"] -> Just Nothing ["merging", branch] -> Just (Just branch) _ -> Nothing - ranCommitAt <- - case Text.words ranCommitAtLine of - ["ran-commit-at"] -> Just Nothing - ["ran-commit-at", text2word64 -> Just n] -> Just (Just n) - _ -> Nothing undos <- Text.stripPrefix "undos " undosLine >>= parseUndos - pure MitState {head, merging, ranCommitAt, undos} + pure MitState {head, merging, undos} readMitState :: Text -> IO (MitState ()) -readMitState branch64 = do +readMitState branch = do head <- gitHead try (Text.readFile (mitfile branch64)) >>= \case Left (_ :: IOException) -> pure emptyMitState @@ -56,30 +57,20 @@ deleteMitState branch64 pure emptyMitState Just state -> pure (state {head = ()} :: MitState ()) + where + branch64 = Text.encodeBase64 branch writeMitState :: Text -> MitState () -> IO () -writeMitState branch64 state = do +writeMitState branch state = do head <- gitHead let contents :: Text contents = Text.unlines [ "head " <> head, "merging " <> fromMaybe Text.empty state.merging, - "ran-commit-at " <> maybe Text.empty word642text state.ranCommitAt, "undos " <> showUndos state.undos ] - Text.writeFile (mitfile branch64) contents `catch` \(_ :: IOException) -> pure () - -mitStateRanCommitAgo :: MitState a -> IO Word64 -mitStateRanCommitAgo state = - case state.ranCommitAt of - Nothing -> pure maxBound - Just timestamp0 -> do - timestamp1 <- getCurrentTime - pure - if timestamp1 >= timestamp0 - then timestamp1 - timestamp0 - else maxBound -- weird unexpected case + Text.writeFile (mitfile (Text.encodeBase64 branch)) contents `catch` \(_ :: IOException) -> pure () mitfile :: Text -> FilePath mitfile branch64 = diff --git a/src/Mit/Undo.hs b/src/Mit/Undo.hs --- a/src/Mit/Undo.hs +++ b/src/Mit/Undo.hs @@ -1,6 +1,14 @@ -module Mit.Undo where +-- TODO replace with Git.Command +module Mit.Undo + ( Undo (..), + showUndos, + parseUndos, + applyUndo, + undosStash, + ) +where -import qualified Data.Text as Text +import Data.Text qualified as Text import Mit.Git import Mit.Prelude diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Main where - -import Control.Monad -import Control.Monad.Free.Church -import Data.Foldable -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Mit hiding (main) -import System.Directory -import System.IO.Temp - -main :: IO () -main = - when False do - test - "no remote branch" - setupRemote0 - setupLocal0 - [ ("test 1", \() -> putStrLn "hi 1"), - ("test 2", \() -> putStrLn "hi 2"), - ("test 3", \() -> putStrLn "hi 3") - ] - -setupRemote0 :: F I () -setupRemote0 = do - icommit_ [("1.txt", ["1", "2", "3"]), ("2.txt", ["1", "2", "3"])] - -setupLocal0 :: () -> F I () -setupLocal0 () = do - ionBranch "feature" do - pure () - -test :: Text -> F I a -> (a -> F I b) -> [(Text, b -> IO ())] -> IO () -test groupName setupRemote setupLocal actions = - for_ actions \(testName, action) -> do - tmpdir <- createTempDirectory "." "mit-test" - createDirectoryIfMissing True (tmpdir ++ "/remote") - setupRemoteResult <- - withCurrentDirectory (tmpdir ++ "/remote") do - git_ ["init", "--initial-branch=master"] - run0 setupRemote - withCurrentDirectory tmpdir (git_ ["clone", "remote", "local"]) - withCurrentDirectory (tmpdir ++ "/local") do - Text.putStrLn ("[" <> groupName <> ", " <> testName <> "]") - setupLocalResult <- run0 (setupLocal setupRemoteResult) - action setupLocalResult - removeDirectoryRecursive tmpdir - where - run0 :: F I a -> IO a - run0 = - iterM \case - Commit files k -> do - for_ files \(path, contents) -> Text.writeFile path (Text.unlines contents) - git_ ["add", "--all"] - git_ ["commit", "--message", "commit"] - commit <- git ["rev-parse", "HEAD"] - k commit - OnBranch branch action k -> do - exists <- git ["show-branch", branch] - if exists then git_ ["switch", branch] else git_ ["switch", "--create", branch] - run0 action >>= k - -data I a - = Commit [(FilePath, [Text])] (Text -> a) - | forall x. OnBranch Text (F I x) (x -> a) - -instance Functor I where - fmap f = \case - Commit a b -> Commit a (f . b) - OnBranch a b c -> OnBranch a b (f . c) - -icommit :: [(FilePath, [Text])] -> F I Text -icommit files = - liftF (Commit files id) - -icommit_ :: [(FilePath, [Text])] -> F I () -icommit_ files = - void (icommit files) - -ionBranch :: Text -> F I a -> F I a -ionBranch branch action = - liftF (OnBranch branch action id)