mit-3qvpPyAi6mH 7 → 8
raw patch · 16 files changed
+1058/−729 lines, 16 filesdep +optparse-applicativedep +parsecdep −clockdep −freedep −record-dot-preprocessordep ~basedep ~base64dep ~containers
Dependencies added: optparse-applicative, parsec
Dependencies removed: clock, free, record-dot-preprocessor, record-hasfield, temporary
Dependency ranges changed: base, base64, containers, directory
Files
- app/Main.hs +2/−2
- mit-3qvpPyAi6mH.cabal +34/−31
- src/Mit.hs +517/−476
- src/Mit/Builder.hs +3/−3
- src/Mit/Clock.hs +0/−12
- src/Mit/Directory.hs +7/−3
- src/Mit/Git.hs +124/−61
- src/Mit/GitCommand.hs +260/−0
- src/Mit/Prelude.hs +8/−3
- src/Mit/Process.hs +5/−2
- src/Mit/Seq.hs +7/−2
- src/Mit/Seq1.hs +36/−21
- src/Mit/Stanza.hs +26/−0
- src/Mit/State.hs +19/−28
- src/Mit/Undo.hs +10/−2
- test/Main.hs +0/−83
app/Main.hs view
@@ -1,6 +1,6 @@-module Main where+module Main (main) where -import qualified Mit+import Mit qualified import Prelude main :: IO ()
mit-3qvpPyAi6mH.cabal view
@@ -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
src/Mit.hs view
@@ -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 <branch>`, so we'll have a `state0.merging` -- that tells us we're merging in <branch>. 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]
src/Mit/Builder.hs view
@@ -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
− src/Mit/Clock.hs
@@ -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))
src/Mit/Directory.hs view
@@ -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 =
src/Mit/Git.hs view
@@ -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)
+ src/Mit/GitCommand.hs view
@@ -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
src/Mit/Prelude.hs view
@@ -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)
src/Mit/Process.hs view
@@ -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)
src/Mit/Seq.hs view
@@ -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
src/Mit/Seq1.hs view
@@ -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
+ src/Mit/Stanza.hs view
@@ -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))
src/Mit/State.hs view
@@ -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 =
src/Mit/Undo.hs view
@@ -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
− test/Main.hs
@@ -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)