diff --git a/mit-3qvpPyAi6mH.cabal b/mit-3qvpPyAi6mH.cabal --- a/mit-3qvpPyAi6mH.cabal +++ b/mit-3qvpPyAi6mH.cabal @@ -11,7 +11,7 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX -version: 5 +version: 6 description: A git wrapper with a streamlined UX. @@ -51,6 +51,7 @@ NoImplicitPrelude NumericUnderscores OverloadedStrings + PatternSynonyms ScopedTypeVariables TupleSections TypeApplications @@ -63,11 +64,17 @@ import: component exposed-modules: Mit + Mit.Clock + Mit.Directory Mit.Git Mit.Globals Mit.Prelude Mit.Process + Mit.Seq Mit.Seq1 + Mit.State + Mit.Undo + ghc-options: -fplugin=RecordDotPreprocessor hs-source-dirs: src executable mit diff --git a/src/Mit.hs b/src/Mit.hs --- a/src/Mit.hs +++ b/src/Mit.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - module Mit where +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as List1 import qualified Data.Sequence as Seq import qualified Data.Text as Text @@ -13,11 +11,14 @@ import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text (Builder) import qualified Data.Text.Lazy.Builder as Text.Builder +import Mit.Clock (getCurrentTime) +import Mit.Directory import Mit.Git import Mit.Prelude +import qualified Mit.Seq as Seq import qualified Mit.Seq1 as Seq1 -import qualified System.Clock as Clock -import System.Directory (doesDirectoryExist, removeFile, withCurrentDirectory) +import Mit.State +import Mit.Undo import System.Environment (getArgs) import System.Exit (ExitCode (..), exitFailure) @@ -60,7 +61,8 @@ dieIfBuggyGit :: IO () dieIfBuggyGit = do version <- gitVersion - case foldr (\(ver, err) acc -> if version < ver then (ver, err) : acc else acc) [] validations of + let validate (ver, err) = if version < ver then ((ver, err) :) else id + case foldr validate [] validations of [] -> pure () errors -> die $ @@ -104,24 +106,20 @@ dieIfNotInGitDir gitBranchWorktreeDir branch >>= \case - Nothing -> - doesDirectoryExist (Text.unpack worktreeDir) >>= \case - False -> do - gitl_ ["worktree", "add", "--detach", worktreeDir] - withCurrentDirectory (Text.unpack worktreeDir) do - gitBranchExists branch >>= \case - False -> do - gitBranch branch - gitSwitch branch - gitFetch_ "origin" - whenM (gitRemoteBranchExists "origin" branch) do - let upstream = "origin/" <> branch - gitl_ ["reset", "--hard", upstream] - gitl_ ["branch", "--set-upstream-to", upstream] - True -> gitSwitch branch - True -> die ["Directory " <> Text.bold worktreeDir <> " already exists."] + Nothing -> do + whenM (doesDirectoryExist worktreeDir) (die ["Directory " <> Text.bold worktreeDir <> " already exists."]) + gitl_ ["worktree", "add", "--detach", worktreeDir] + withCurrentDirectory worktreeDir do + whenNotM (gitSwitch branch) do + gitBranch branch + gitSwitch_ branch + gitFetch_ "origin" + whenM (gitRemoteBranchExists "origin" branch) do + let upstream = "origin/" <> branch + gitl_ ["reset", "--hard", upstream] + gitl_ ["branch", "--set-upstream-to", upstream] Just directory -> - unless (directory == worktreeDir) do + when (directory /= worktreeDir) do die [Text.bold branch <> " is already checked out in " <> Text.bold directory <> "."] where worktreeDir :: Text @@ -150,26 +148,32 @@ existLocalCommits <- maybe (pure True) (\upstreamHead -> gitExistCommitsBetween upstreamHead "HEAD") maybeUpstreamHead state0 <- readMitState branch64 + stash <- gitCreateStash + let wouldFork = existRemoteCommits && not existLocalCommits + let shouldWarnAboutFork = if wouldFork then do - let theyRanMitCommitRecently = - case state0.ranCommitAt of - Nothing -> pure False - Just t0 -> do - t1 <- Clock.toNanoSecs <$> Clock.getTime Clock.Realtime - pure ((t1 - t0) < 10_000_000_000) - not <$> theyRanMitCommitRecently + ago <- mitStateRanCommitAgo state0 + if ago < 10_000_000_000 + then pure False + else do + git_ ["reset", "--hard", fromJust maybeUpstreamHead] + canMergeCleanly <- git ["stash", "apply", stash] + git_ ["reset", "--hard", head] + git_ ["stash", "apply", stash] + gitUnstageChanges + pure canMergeCleanly else pure False -- Bail out early if we should warn that this commit would fork history whenM shouldWarnAboutFork do - ranCommitAt <- Just . Clock.toNanoSecs <$> Clock.getTime Clock.Realtime + ranCommitAt <- Just <$> getCurrentTime writeMitState branch64 state0 {ranCommitAt} putLines [ "", - " " <> Text.yellow (Text.italic branch <> " is not up to date."), + " " <> Text.yellow (Text.italic branch <> " is not up-to-date."), "", " Run " <> Text.bold (Text.blue "mit sync") <> " first, or run " <> Text.bold (Text.blue "mit commit") <> " again to record a commit anyway.", @@ -177,16 +181,15 @@ ] exitFailure - stash <- gitCreateStash committed <- gitCommit localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD" pushResult <- case (localCommits, existRemoteCommits, fetched) of (Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush) - (_ Seq.:<| _, True, _) -> pure (PushNotAttempted ForkedHistory) - (_ Seq.:<| _, False, False) -> pure (PushNotAttempted Offline) - (_ Seq.:<| _, False, True) -> PushAttempted <$> gitPush branch + (Seq.NonEmpty, True, _) -> pure (PushNotAttempted ForkedHistory) + (Seq.NonEmpty, False, False) -> pure (PushNotAttempted Offline) + (Seq.NonEmpty, False, True) -> PushAttempted <$> gitPush branch let pushed = case pushResult of @@ -196,17 +199,17 @@ -- Only bother resetting the "ran commit at" if we would fork and the commit was aborted ranCommitAt <- case (wouldFork, committed) of - (True, False) -> Just . Clock.toNanoSecs <$> Clock.getTime Clock.Realtime + (True, False) -> Just <$> getCurrentTime _ -> pure Nothing undos <- case (pushed, committed, localCommits) of (False, False, _) -> pure state0.undos (False, True, _) -> pure [Reset head, Apply stash] - (True, True, _ Seq.:<| Seq.Empty) -> do + (True, True, Seq.Singleton) -> do head1 <- gitHead pure [Revert head1, Apply stash] - (True, _, _) -> pure [] + _ -> pure [] writeMitState branch64 MitState {head = (), merging = Nothing, ranCommitAt, undos} @@ -311,7 +314,7 @@ undos = case maybeMergeStatus of Nothing -> [] - Just mergeStatus -> mergeStatus.undos + Just mergeStatus -> List1.toList mergeStatus.undos } putSummary @@ -343,7 +346,7 @@ data MergeStatus = MergeStatus { commits :: Seq1 GitCommitInfo, result :: MergeResult, - undos :: [Undo] -- FIXME List1 + undos :: List1 Undo } data MergeResult @@ -357,7 +360,7 @@ Nothing -> pure Nothing Just commits -> do maybeStash <- gitStash - let undos = Reset head : maybeToList (Apply <$> maybeStash) + let undos = Reset head :| maybeToList (Apply <$> maybeStash) result <- gitl ["merge", "--ff", "--no-commit", target] >>= \case False -> do @@ -436,10 +439,10 @@ -- "forked history" is ok - a bit different than history *already* having forked, in which case a push -- would just fail, whereas this is just us choosing not to push while in the middle of a merge due to a -- previous fork in the history - (_ Seq.:<| _, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory) - (_ Seq.:<| _, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits) - (_ Seq.:<| _, Nothing, False) -> pure (PushNotAttempted Offline) - (_ Seq.:<| _, Nothing, True) -> PushAttempted <$> gitPush branch + (Seq.NonEmpty, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory) + (Seq.NonEmpty, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits) + (Seq.NonEmpty, Nothing, False) -> pure (PushNotAttempted Offline) + (Seq.NonEmpty, Nothing, True) -> PushAttempted <$> gitPush branch let pushed = case pushResult of @@ -448,7 +451,7 @@ let undos = case pushed of - False -> fromMaybe (maybe [] (.undos) maybeMergeStatus) maybeUndos + False -> fromMaybe (maybe [] (List1.toList . (.undos)) maybeMergeStatus) maybeUndos True -> [] writeMitState @@ -578,108 +581,4 @@ then [" Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change.", ""] else [] --- State file - -data MitState a = MitState - { head :: a, - merging :: Maybe Text, - ranCommitAt :: Maybe Integer, - undos :: [Undo] - } - deriving stock (Eq, Show) - -emptyMitState :: MitState () -emptyMitState = - MitState {head = (), merging = Nothing, ranCommitAt = Nothing, undos = []} - -deleteMitState :: Text -> IO () -deleteMitState branch64 = - removeFile (mitfile branch64) `catch` \(_ :: IOException) -> pure () - -parseMitState :: Text -> Maybe (MitState Text) -parseMitState contents = do - [headLine, mergingLine, ranCommitAtLine, 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", text2int -> Just n] -> Just (Just n) - _ -> Nothing - undos <- Text.stripPrefix "undos " undosLine >>= parseUndos - pure MitState {head, merging, ranCommitAt, undos} - -readMitState :: Text -> IO (MitState ()) -readMitState branch64 = do - head <- gitHead - try (Text.readFile (mitfile branch64)) >>= \case - Left (_ :: IOException) -> pure emptyMitState - Right contents -> do - let maybeState = do - state <- parseMitState contents - guard (head == state.head) - pure state - case maybeState of - Nothing -> do - deleteMitState branch64 - pure emptyMitState - Just state -> pure (state {head = ()} :: MitState ()) - -writeMitState :: Text -> MitState () -> IO () -writeMitState branch64 state = do - head <- gitHead - let contents :: Text - contents = - Text.unlines - [ "head " <> head, - "merging " <> fromMaybe Text.empty state.merging, - "ran-commit-at " <> maybe Text.empty int2text state.ranCommitAt, - "undos " <> showUndos state.undos - ] - Text.writeFile (mitfile branch64) contents `catch` \(_ :: IOException) -> pure () - -mitfile :: Text -> FilePath -mitfile branch64 = - Text.unpack (gitdir <> "/.mit-" <> branch64) - -- Undo file utils - -data Undo - = Apply Text -- apply stash - | Reset Text -- reset to commit - | Revert Text -- revert commit - deriving stock (Eq, Show) - -showUndos :: [Undo] -> Text -showUndos = - Text.intercalate " " . map showUndo - where - showUndo :: Undo -> Text - showUndo = \case - Apply commit -> "apply/" <> commit - Reset commit -> "reset/" <> commit - Revert commit -> "revert/" <> commit - -parseUndos :: Text -> Maybe [Undo] -parseUndos t0 = do - (Text.words >>> traverse parseUndo) t0 - where - parseUndo :: Text -> Maybe Undo - parseUndo text = - asum - [ Apply <$> Text.stripPrefix "apply/" text, - Reset <$> Text.stripPrefix "reset/" text, - Revert <$> Text.stripPrefix "revert/" text, - error (show text) - ] - -applyUndos :: List1 Undo -> IO () -applyUndos = - traverse_ \case - Apply commit -> void (gitApplyStash commit) - Reset commit -> gitResetHard commit - Revert commit -> gitRevert commit diff --git a/src/Mit/Clock.hs b/src/Mit/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Clock.hs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Mit/Directory.hs @@ -0,0 +1,13 @@ +module Mit.Directory where + +import qualified Data.Text as Text +import Mit.Prelude +import qualified System.Directory as Directory + +doesDirectoryExist :: Text -> IO Bool +doesDirectoryExist = + Directory.doesDirectoryExist . Text.unpack + +withCurrentDirectory :: Text -> IO a -> IO a +withCurrentDirectory dir = + Directory.withCurrentDirectory (Text.unpack dir) diff --git a/src/Mit/Git.hs b/src/Mit/Git.hs --- a/src/Mit/Git.hs +++ b/src/Mit/Git.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - module Mit.Git where import qualified Data.List as List @@ -8,7 +6,6 @@ import qualified Data.Text.ANSI as Text import qualified Data.Text.Builder.ANSI as Text.Builder import qualified Data.Text.IO as Text -import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Builder as Text (Builder) import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Ki @@ -118,7 +115,7 @@ gitApplyStash :: Text -> IO [GitConflict] gitApplyStash stash = do conflicts <- - gitl ["stash", "apply", stash] >>= \case + git ["stash", "apply", stash] >>= \case False -> gitConflicts True -> pure [] gitUnstageChanges @@ -195,7 +192,7 @@ gitCreateStash :: IO Text gitCreateStash = do git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed - stash <- gitl ["stash", "create"] + stash <- git ["stash", "create"] gitUnstageChanges pure stash @@ -204,6 +201,11 @@ gitCurrentBranch = git ["branch", "--show-current"] +gitDefaultBranch :: Text -> IO Text +gitDefaultBranch remote = do + ref <- git ["symbolic-ref", "refs/remotes/" <> remote <> "/HEAD"] + pure (Text.drop (14 + Text.length remote) ref) + -- FIXME document this gitDiff :: IO DiffResult gitDiff = do @@ -240,40 +242,6 @@ gitListUntrackedFiles = git ["ls-files", "--exclude-standard", "--other"] --- FIXME document what this does -gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ()) -gitMerge me target = do - gitl ["merge", "--ff", "--no-commit", target] >>= \case - False -> - (pure . Left) do - conflicts <- gitConflicts - gitl_ ["add", "--all"] - gitl_ ["commit", "--no-edit", "--message", mergeMessage conflicts] - pure conflicts - True -> do - whenM gitMergeInProgress (gitl_ ["commit", "--message", mergeMessage []]) - pure (Right ()) - where - mergeMessage :: [GitConflict] -> Text - mergeMessage conflicts = - (Text.Lazy.toStrict . Text.Builder.toLazyText . fold) - [ "⅄", - if null conflicts then "" else "\x0338", - " ", - if target' == me - then Text.Builder.fromText me - else Text.Builder.fromText target' <> " → " <> Text.Builder.fromText me, - if null conflicts - then "" - else - " (conflicts)\n\nConflicting files:\n" - <> mconcat (List.intersperse "\n" (map ((" " <>) . showGitConflict) conflicts)) - ] - where - target' :: Text - target' = - fromMaybe target (Text.stripPrefix "origin/" target) - gitMergeInProgress :: IO Bool gitMergeInProgress = doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD")) @@ -294,35 +262,30 @@ Left _ -> Nothing Right head -> Just head --- | Blow away untracked files, and hard-reset to the given commit -gitResetHard :: Text -> IO () -gitResetHard commit = do - gitl_ ["clean", "-d", "--force"] - gitl ["reset", "--hard", commit] - -gitRevert :: Text -> IO () -gitRevert commit = - gitl_ ["revert", commit] - -- | Stash uncommitted changes (if any). gitStash :: IO (Maybe Text) gitStash = do gitDiff >>= \case Differences -> do stash <- gitCreateStash - gitResetHard "HEAD" + git_ ["clean", "-d", "--force"] + git_ ["reset", "--hard", "HEAD"] pure (Just stash) NoDifferences -> pure Nothing -gitSwitch :: Text -> IO () +gitSwitch :: Text -> IO Bool gitSwitch branch = + git ["switch", branch] + +gitSwitch_ :: Text -> IO () +gitSwitch_ branch = git_ ["switch", branch] gitUnstageChanges :: IO () gitUnstageChanges = do - gitl_ ["reset", "--mixed"] + git_ ["reset", "--mixed"] untrackedFiles <- gitListUntrackedFiles - unless (null untrackedFiles) (gitl_ ("add" : "--intent-to-add" : untrackedFiles)) + unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles)) gitVersion :: IO GitVersion gitVersion = do diff --git a/src/Mit/Prelude.hs b/src/Mit/Prelude.hs --- a/src/Mit/Prelude.hs +++ b/src/Mit/Prelude.hs @@ -17,6 +17,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Traversable as X +import Data.Word as X (Word64) import Mit.Seq1 as X (Seq1) import Text.Read as X (readMaybe) import Prelude as X hiding (head, id) @@ -33,8 +34,8 @@ error . Text.unpack -- FIXME make this faster -int2text :: Integer -> Text -int2text = +word642text :: Word64 -> Text +word642text = Text.pack . show putLines :: [Text] -> IO () @@ -46,8 +47,8 @@ if Text.any isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s -- FIXME make this faster -text2int :: Text -> Maybe Integer -text2int = +text2word64 :: Text -> Maybe Word64 +text2word64 = readMaybe . Text.unpack onLeftM :: Monad m => (a -> m b) -> m (Either a b) -> m b @@ -73,3 +74,7 @@ mx >>= \case False -> pure () True -> action + +whenNotM :: Monad m => m Bool -> m () -> m () +whenNotM mx = + whenM (not <$> mx) diff --git a/src/Mit/Seq.hs b/src/Mit/Seq.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Seq.hs @@ -0,0 +1,11 @@ +module Mit.Seq where + +import Data.Sequence + +pattern NonEmpty :: Seq a +pattern NonEmpty <- _ :<| _ + +{-# COMPLETE Empty, NonEmpty #-} + +pattern Singleton :: Seq a +pattern Singleton <- _ :<| Empty diff --git a/src/Mit/State.hs b/src/Mit/State.hs new file mode 100644 --- /dev/null +++ b/src/Mit/State.hs @@ -0,0 +1,86 @@ +module Mit.State where + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Mit.Clock (getCurrentTime) +import Mit.Git +import Mit.Prelude +import Mit.Undo +import System.Directory (removeFile) + +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 = []} + +deleteMitState :: Text -> IO () +deleteMitState branch64 = + removeFile (mitfile branch64) `catch` \(_ :: IOException) -> pure () + +parseMitState :: Text -> Maybe (MitState Text) +parseMitState contents = do + [headLine, mergingLine, ranCommitAtLine, 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} + +readMitState :: Text -> IO (MitState ()) +readMitState branch64 = do + head <- gitHead + try (Text.readFile (mitfile branch64)) >>= \case + Left (_ :: IOException) -> pure emptyMitState + Right contents -> do + let maybeState = do + state <- parseMitState contents + guard (head == state.head) + pure state + case maybeState of + Nothing -> do + deleteMitState branch64 + pure emptyMitState + Just state -> pure (state {head = ()} :: MitState ()) + +writeMitState :: Text -> MitState () -> IO () +writeMitState branch64 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 + +mitfile :: Text -> FilePath +mitfile branch64 = + Text.unpack (gitdir <> "/.mit-" <> branch64) diff --git a/src/Mit/Undo.hs b/src/Mit/Undo.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Undo.hs @@ -0,0 +1,45 @@ +module Mit.Undo where + +import qualified Data.Text as Text +import Mit.Git +import Mit.Prelude + +data Undo + = Apply Text -- apply stash + | Reset Text -- reset to commit + | Revert Text -- revert commit + deriving stock (Eq, Show) + +showUndos :: [Undo] -> Text +showUndos = + Text.intercalate " " . map showUndo + where + showUndo :: Undo -> Text + showUndo = \case + Apply commit -> "apply/" <> commit + Reset commit -> "reset/" <> commit + Revert commit -> "revert/" <> commit + +parseUndos :: Text -> Maybe [Undo] +parseUndos = do + Text.words >>> traverse parseUndo + where + parseUndo :: Text -> Maybe Undo + parseUndo text = + asum + [ Apply <$> Text.stripPrefix "apply/" text, + Reset <$> Text.stripPrefix "reset/" text, + Revert <$> Text.stripPrefix "revert/" text, + error (show text) + ] + +applyUndos :: List1 Undo -> IO () +applyUndos = + traverse_ \case + Apply commit -> do + gitl_ ["stash", "apply", commit] + gitUnstageChanges + Reset commit -> do + gitl_ ["clean", "-d", "--force"] + gitl ["reset", "--hard", commit] + Revert commit -> gitl_ ["revert", commit]