diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,1066 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -module Main where - -import Control.Category ((>>>)) -import Control.Exception (AsyncException (UserInterrupt), IOException, catch, evaluate, throwIO, try) -import Control.Monad -import Data.Char -import Data.Foldable (fold, for_) -import Data.Function -import qualified Data.List as List -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.ANSI as Text -import qualified Data.Text.Encoding.Base64 as Text -import qualified Data.Text.IO as Text -import qualified System.Clock as Clock -import System.Directory (doesDirectoryExist, doesFileExist, removeFile, withCurrentDirectory) -import System.Environment (getArgs, lookupEnv) -import System.Exit (ExitCode (..), exitFailure, exitWith) -import System.IO (Handle, hIsEOF) -import System.IO.Unsafe (unsafePerformIO) -import System.Posix.Terminal (queryTerminal) -import System.Process -import Text.Read (readMaybe) -import Prelude hiding (head) - --- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit --- ephemeral feeling --- FIXME bail if active cherry-pick, active revert, active rebase, what else? --- FIXME rev-list max 11, use ellipses after 10 --- FIXME test file deleted by us/them conflict - --- TODO mit init --- TODO mit delete-branch --- TODO tweak things to work with git < 2.30.1 --- TODO rewrite mit commit algorithm in readme --- TODO git(hub,lab) flow or something? --- TODO 'mit branch' with dirty working directory - apply changes to new worktree? --- TODO undo in more cases? --- TODO recommend merging master if it conflicts - -main :: IO () -main = do - getArgs >>= \case - ["branch", branch] -> mitBranch (Text.pack branch) - ["clone", parseGitRepo . Text.pack -> Just (url, name)] -> mitClone url name - ["commit"] -> mitCommit - ["merge", branch] -> mitMerge (Text.pack branch) -- temporary? - ["sync"] -> mitSync - ["undo"] -> mitUndo - _ -> - putLines - [ "Usage:", - " mit branch ≪branch≫", - " mit clone ≪repo≫", - " mit commit", - " mit merge ≪branch≫", - " mit sync", - " mit undo" - ] - -dieIfBuggyGit :: IO () -dieIfBuggyGit = do - version <- gitVersion - case foldr (\(ver, err) acc -> if version < ver then (ver, err) : acc else acc) [] validations of - [] -> pure () - errors -> - die $ - map - (\(ver, err) -> "Prior to " <> Text.bold "git" <> " version " <> showGitVersion ver <> ", " <> err) - errors - where - validations :: [(GitVersion, Text)] - validations = - [ ( GitVersion 2 29 0, - Text.bold "git commit --patch" - <> " was broken for new files added with " - <> Text.bold "git add --intent-to-add" - <> "." - ), - ( GitVersion 2 30 1, - Text.bold "git stash create" - <> " was broken for new files added with " - <> Text.bold "git add --intent-to-add" - <> "." - ) - ] - -dieIfMergeInProgress :: IO () -dieIfMergeInProgress = - whenM gitMergeInProgress (die [Text.bold "git merge" <> " in progress."]) - -dieIfNotInGitDir :: IO () -dieIfNotInGitDir = - try (evaluate gitdir) >>= \case - Left (_ :: ExitCode) -> exitFailure - Right _ -> pure () - -die :: [Text] -> IO a -die ss = do - Text.putStr (Text.red (Text.unlines ss)) - exitFailure - -mitBranch :: Text -> IO () -mitBranch branch = do - dieIfNotInGitDir - - unlessM (doesDirectoryExist (Text.unpack worktreeDir)) do - worktrees :: [(Text, Text, Maybe Text)] <- - gitWorktreeList - - case List.find (\(_, _, worktreeBranch) -> worktreeBranch == Just branch) worktrees of - Nothing -> do - git_ ["worktree", "add", "--detach", worktreeDir] - withCurrentDirectory (Text.unpack worktreeDir) do - git ["rev-parse", "--verify", "refs/heads/" <> branch] >>= \case - False -> do - git_ ["branch", "--no-track", branch] - git_ ["switch", branch] - - _fetchResult :: Bool <- - git ["fetch", "origin"] - - whenM (git ["rev-parse", "--verify", "refs/remotes/" <> upstream]) do - git_ ["reset", "--hard", upstream] - git_ ["branch", "--set-upstream-to", upstream] - True -> git_ ["switch", branch] - Just (dir, _, _) -> - unless (worktreeDir == dir) do - Text.putStrLn ("Branch " <> Text.bold branch <> " is already checked out in " <> Text.bold dir) - exitFailure - where - upstream :: Text - upstream = - "origin/" <> branch - - worktreeDir :: Text - worktreeDir = - Text.dropWhileEnd (/= '/') gitdir <> branch - -mitClone :: Text -> Text -> IO () -mitClone url name = - -- FIXME use 'git config --get init.defaultBranch - git ["clone", url, "--separate-git-dir", name <> "/.git", name <> "/master"] - -mitCommit :: IO () -mitCommit = do - dieIfNotInGitDir - dieIfMergeInProgress - whenM gitExistUntrackedFiles dieIfBuggyGit - - context <- makeContext - case context.dirty of - Differences -> mitCommitWith context - NoDifferences -> mitSyncWith context -- n.b. not covered by tests (would be dupes of sync tests) - -mitCommitWith :: Context -> IO () -mitCommitWith context = do - maybeUpstreamHead :: Maybe Text <- - git ["rev-parse", "refs/remotes/" <> context.upstream] <&> \case - Left _ -> Nothing - Right upstreamHead -> Just upstreamHead - - remoteCommits :: [GitCommitInfo] <- - case maybeUpstreamHead of - Nothing -> pure [] - Just upstreamHead -> gitCommitsBetween (Just context.head) upstreamHead - - localCommits0 :: [GitCommitInfo] <- - gitCommitsBetween maybeUpstreamHead "HEAD" - - when (not (null remoteCommits) && null localCommits0) do - readCommitFile context.branch64 >>= \case - Just (hash, age) | hash == context.head && age < 10_000_000_000 -> pure () - _ -> do - recordCommitFile context.branch64 context.head - putLines - [ "", - " " <> Text.italic context.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.", - "" - ] - exitFailure - - stash :: Text <- - gitCreateStash - - commitResult :: Bool <- - gitCommit - - -- If the commit was aborted, reset the timer (allowing another 'mit commit' right away). Otherwise, delete the commit - -- file, because it's no longer needed. - case commitResult of - False -> recordCommitFile context.branch64 context.head - True -> deleteCommitFile context.branch64 - - localCommits :: [GitCommitInfo] <- - case commitResult of - False -> pure localCommits0 - True -> gitCommitsBetween maybeUpstreamHead "HEAD" - - pushResult :: PushResult <- - if - | null localCommits -> pure (PushNotAttempted PushNoCommits) - | not (null remoteCommits) -> pure (PushNotAttempted PushWouldConflict) - | context.fetchFailed -> pure (PushNotAttempted PushOffline) - | otherwise -> PushAttempted <$> gitPush context.branch - - canUndo :: Bool <- do - let pushDidntHappen = do - head <- git ["rev-parse", "HEAD"] - case head == context.head of - False -> do - recordUndoFile context.branch64 [Reset context.head, Apply stash] - pure True - True -> pure False - case pushResult of - PushAttempted True -> - case commitResult of - False -> do - deleteUndoFile context.branch64 - pure False - True -> - case localCommits of - [_] -> do - -- FIXME this call wouldn't be necessary if we don't pretty-print local commits right away - head <- git ["rev-parse", "HEAD"] - recordUndoFile context.branch64 [Revert head, Apply stash] - pure True - _ -> do - deleteUndoFile context.branch64 - pure False - PushAttempted False -> pushDidntHappen - PushNotAttempted _ -> pushDidntHappen - - putSummary - Summary - { branch = context.branch, - canUndo, - conflicts = [], - syncs = - [ Sync - { commits = localCommits, - result = pushResultToSyncResult pushResult, - source = context.branch, - target = context.upstream - } - ] - } - -data PushResult - = PushAttempted Bool - | PushNotAttempted PushNotAttemptedReason - -data PushNotAttemptedReason - = PushCommitHasConflicts -- local commit has conflict markers - | PushNewCommits -- we just pulled remote commits; don't push in case there's something local to address - | PushNoCommits -- no commits to push - | PushOffline -- fetch failed, so we seem offline - | PushWouldConflict -- local history has forked, need to sync - -pushResultToSyncResult :: PushResult -> SyncResult -pushResultToSyncResult = \case - PushAttempted True -> Success - PushAttempted False -> Failure - PushNotAttempted PushCommitHasConflicts -> Failure - PushNotAttempted PushNewCommits -> Pending - PushNotAttempted PushNoCommits -> Success -- doesnt matter, wont be shown - PushNotAttempted PushOffline -> Offline - PushNotAttempted PushWouldConflict -> Failure - -mitMerge :: Text -> IO () -mitMerge target0 = do - dieIfNotInGitDir - dieIfMergeInProgress - whenM gitExistUntrackedFiles dieIfBuggyGit - - context :: Context <- - makeContext - - -- When given 'mit merge foo', prefer merging 'origin/foo' over 'foo' - target :: Text <- do - let remote = "origin/" <> target0 - git ["rev-parse", "--verify", remote] <&> \case - False -> target0 - True -> remote - - maybeTargetCommit :: Maybe Text <- - git ["rev-parse", target] <&> \case - Left _ -> Nothing - Right targetCommit -> Just targetCommit - - targetCommits :: [GitCommitInfo] <- - case maybeTargetCommit of - Nothing -> pure [] - Just targetCommit -> gitCommitsBetween (Just context.head) targetCommit - - maybeStash :: Maybe Text <- - case (targetCommits, context.dirty) of - (_ : _, Differences) -> Just <$> gitStash - _ -> pure Nothing - - mergeConflicts :: Maybe [GitConflict] <- - case targetCommits of - [] -> pure Nothing - _ -> - fmap Just do - gitMerge context.branch target >>= \case - Left commitConflicts -> commitConflicts - Right () -> pure [] - - stashConflicts :: [GitConflict] <- - case maybeStash of - Nothing -> pure [] - Just stash -> gitApplyStash stash - - canUndo :: Bool <- do - head <- git ["rev-parse", "HEAD"] - if head == context.head - then pure False - else do - recordUndoFile context.branch64 (Reset context.head : maybeToList (Apply <$> maybeStash)) - pure True - - putSummary - Summary - { branch = context.branch, - canUndo, - -- FIXME this is dubious, nub made more sense when conflicts were just filenames... - conflicts = List.nub (stashConflicts ++ fromMaybe [] mergeConflicts), - syncs = - [ Sync - { commits = targetCommits, - result = - case mergeConflicts of - Just (_ : _) -> Failure - _ -> Success, - source = target, - target = context.branch - } - ] - } - --- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream -mitSync :: IO () -mitSync = do - dieIfNotInGitDir - dieIfMergeInProgress - whenM gitExistUntrackedFiles dieIfBuggyGit - context <- makeContext - mitSyncWith context - -mitSyncWith :: Context -> IO () -mitSyncWith context = do - maybeUpstreamHead :: Maybe Text <- - git ["rev-parse", "refs/remotes/" <> context.upstream] <&> \case - Left _ -> Nothing - Right upstreamHead -> Just upstreamHead - - remoteCommits :: [GitCommitInfo] <- - case maybeUpstreamHead of - Nothing -> pure [] - Just upstreamHead -> gitCommitsBetween (Just context.head) upstreamHead - - maybeStash :: Maybe Text <- - case (remoteCommits, context.dirty) of - (_ : _, Differences) -> Just <$> gitStash - _ -> pure Nothing - - mergeConflicts :: Maybe [GitConflict] <- - case remoteCommits of - [] -> pure Nothing - _ -> - fmap Just do - gitMerge context.branch context.upstream >>= \case - Left commitConflicts -> commitConflicts - Right () -> pure [] - - localCommits :: [GitCommitInfo] <- - gitCommitsBetween maybeUpstreamHead "HEAD" - - stashConflicts :: [GitConflict] <- - case maybeStash of - Nothing -> pure [] - Just stash -> gitApplyStash stash - - pushResult :: PushResult <- - case localCommits of - [] -> pure (PushNotAttempted PushNoCommits) - _ -> - case mergeConflicts of - Nothing -> - case context.fetchFailed of - False -> PushAttempted <$> gitPush context.branch - True -> pure (PushNotAttempted PushOffline) - Just [] -> pure (PushNotAttempted PushNewCommits) - Just (_ : _) -> pure (PushNotAttempted PushWouldConflict) - - canUndo :: Bool <- do - let pushDidntHappen = do - head2 <- git ["rev-parse", "HEAD"] - if context.head == head2 - then pure False -- head didn't move; nothing to undo - else do - recordUndoFile context.branch64 (Reset context.head : maybeToList (Apply <$> maybeStash)) - pure True - case pushResult of - PushAttempted True -> do - deleteUndoFile context.branch64 - pure False - PushAttempted False -> pushDidntHappen - PushNotAttempted _ -> pushDidntHappen - - putSummary - Summary - { branch = context.branch, - canUndo, - -- FIXME this is dubious, nub made more sense when conflicts were just filenames... - conflicts = List.nub (stashConflicts ++ fromMaybe [] mergeConflicts), - syncs = - [ Sync - { commits = remoteCommits, - result = - case mergeConflicts of - Just (_ : _) -> Failure - _ -> Success, - source = context.upstream, - target = context.branch - }, - Sync - { commits = localCommits, - result = pushResultToSyncResult pushResult, - source = context.branch, - target = context.upstream - } - ] - } - --- FIXME output what we just undid -mitUndo :: IO () -mitUndo = do - dieIfNotInGitDir - - branch64 <- Text.encodeBase64 <$> gitCurrentBranch - readUndoFile branch64 >>= \case - Nothing -> exitFailure - Just undos -> do - deleteUndoFile branch64 - for_ undos \case - Apply commit -> do - -- This should never return conflicts - -- FIXME assert? - _conflicts <- gitApplyStash commit - pure () - Reset commit -> gitResetHard commit - Revert commit -> git_ ["revert", commit] - when (undosContainRevert undos) mitSync - where - undosContainRevert :: [Undo] -> Bool - undosContainRevert = \case - [] -> False - Revert _ : _ -> True - _ : undos -> undosContainRevert undos - -data Context = Context - { branch :: Text, - branch64 :: Text, - dirty :: DiffResult, - fetchFailed :: Bool, - head :: Text, - upstream :: Text - } - -makeContext :: IO Context -makeContext = do - branch <- gitCurrentBranch - dirty <- gitDiff - head <- git ["rev-parse", "HEAD"] - fetchFailed <- not <$> git ["fetch", "origin"] - pure - Context - { branch, - branch64 = Text.encodeBase64 branch, - dirty, - fetchFailed, - head, - upstream = "origin/" <> branch - } - -data Summary = Summary - { branch :: Text, - canUndo :: Bool, - conflicts :: [GitConflict], - syncs :: [Sync] - } - -data Sync = Sync - { commits :: [GitCommitInfo], - result :: SyncResult, - source :: Text, - target :: Text - } - -data SyncResult - = Offline - | Failure - | Pending - | Success - --- FIXME show some graph of where local/remote is at -putSummary :: Summary -> IO () -putSummary summary = - let output = concatMap syncLines summary.syncs ++ conflictsLines ++ undoLines - in if null output then pure () else putLines ("" : output) - where - conflictsLines :: [Text] - conflictsLines = - if null summary.conflicts - then [] - else - " The following files have conflicts." : - map ((" " <>) . Text.red . showGitConflict) summary.conflicts ++ [""] - syncLines :: Sync -> [Text] - syncLines sync = - if null sync.commits - then [] - else - colorize (Text.italic (" " <> sync.source <> " → " <> sync.target)) : - map ((" " <>) . prettyGitCommitInfo) sync.commits - ++ [""] - where - colorize :: Text -> Text - colorize = - case sync.result of - Offline -> Text.brightBlack - Failure -> Text.red - Pending -> Text.yellow - Success -> Text.green - undoLines :: [Text] - undoLines = - if summary.canUndo - then [" Run " <> Text.bold (Text.blue "mit undo") <> " to undo this change.", ""] - else [] - --- Commit file utils - -deleteCommitFile :: Text -> IO () -deleteCommitFile branch64 = - removeFile (commitfile branch64) `catch` \(_ :: IOException) -> pure () - --- | Read the amount of time that has elapsed (in nanoseconds) since the commit file was created -readCommitFile :: Text -> IO (Maybe (Text, Integer)) -readCommitFile branch64 = do - try (Text.readFile (commitfile branch64)) >>= \case - Left (_ :: IOException) -> pure Nothing - Right contents -> - case Text.split (== ',') contents of - [hash, text2int -> Just t0] -> do - t1 <- Clock.getTime Clock.Realtime - pure (Just (hash, Clock.toNanoSecs t1 - t0)) - _ -> do - deleteCommitFile branch64 - pure Nothing - where - -- FIXME make this faster - text2int :: Text -> Maybe Integer - text2int = - readMaybe . Text.unpack - -recordCommitFile :: Text -> Text -> IO () -recordCommitFile branch64 hash = do - now <- Clock.getTime Clock.Realtime - -- FIXME use builder - let contents = hash <> "," <> int2text (Clock.toNanoSecs now) - Text.writeFile (commitfile branch64) contents `catch` \(_ :: IOException) -> pure () - where - -- FIXME make this faster - int2text :: Integer -> Text - int2text = - Text.pack . show - -commitfile :: Text -> FilePath -commitfile branch64 = - Text.unpack (gitdir <> "/.mit-" <> branch64 <> "-commit") - --- Undo file utils - -data Undo - = Apply Text -- apply stash - | Reset Text -- reset to commit - | Revert Text -- revert commit - -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 = - Text.split (== ',') >>> traverse parseUndo - where - parseUndo :: Text -> Maybe Undo - parseUndo = - Text.words >>> \case - ["apply", commit] -> Just (Apply commit) - ["reset", commit] -> Just (Reset commit) - ["revert", commit] -> Just (Revert commit) - _ -> Nothing - -deleteUndoFile :: Text -> IO () -deleteUndoFile branch64 = - removeFile (undofile branch64) `catch` \(_ :: IOException) -> pure () - -readUndoFile :: Text -> IO (Maybe [Undo]) -readUndoFile branch64 = - try (Text.readFile file) >>= \case - Left (_ :: IOException) -> pure Nothing - Right contents -> - case parseUndos contents of - Nothing -> do - when debug (putStrLn ("Corrupt undo file: " ++ file)) - pure Nothing - Just undos -> pure (Just undos) - where - file :: FilePath - file = - undofile branch64 - --- Record a file for 'mit undo' to use, if invoked. -recordUndoFile :: Text -> [Undo] -> IO () -recordUndoFile branch64 undos = do - Text.writeFile (undofile branch64) (showUndos undos) `catch` \(_ :: IOException) -> pure () - -undofile :: Text -> FilePath -undofile branch64 = - Text.unpack (gitdir <> "/.mit-" <> branch64) - --- Globals - -debug :: Bool -debug = - isJust (unsafePerformIO (lookupEnv "debug")) -{-# NOINLINE debug #-} - -gitdir :: Text -gitdir = - unsafePerformIO (git ["rev-parse", "--absolute-git-dir"]) -{-# NOINLINE gitdir #-} - --- Git helpers - -data DiffResult - = Differences - | NoDifferences - -data GitCommitInfo = GitCommitInfo - { author :: Text, - date :: Text, - hash :: Text, - shorthash :: Text, - subject :: Text - } - deriving stock (Show) - -prettyGitCommitInfo :: GitCommitInfo -> Text -prettyGitCommitInfo info = - -- FIXME use builder - fold - [ Text.bold (Text.black info.shorthash), - " ", - Text.bold (Text.white info.subject), - " - ", - Text.italic (Text.white info.author), - " ", - Text.italic (Text.yellow info.date) -- FIXME some other color, magenta? - ] - -data GitConflict - = GitConflict GitConflictXY Text - deriving stock (Eq) - -parseGitConflict :: Text -> Maybe GitConflict -parseGitConflict line = do - [xy, name] <- Just (Text.words line) - GitConflict <$> parseGitConflictXY xy <*> Just name - --- FIXME builder -showGitConflict :: GitConflict -> Text -showGitConflict (GitConflict xy name) = - name <> " (" <> showGitConflictXY xy <> ")" - -data GitConflictXY - = AA -- both added - | AU -- added by us - | DD -- both deleted - | DU -- deleted by us - | UA -- added by them - | UD -- deleted by them - | UU -- both modified - deriving stock (Eq) - -parseGitConflictXY :: Text -> Maybe GitConflictXY -parseGitConflictXY = \case - "AA" -> Just AA - "AU" -> Just AU - "DD" -> Just DD - "DU" -> Just DU - "UA" -> Just UA - "UD" -> Just UD - "UU" -> Just UU - _ -> Nothing - --- FIXME builder -showGitConflictXY :: GitConflictXY -> Text -showGitConflictXY = \case - AA -> "both added" - AU -> "added by us" - DD -> "both deleted" - DU -> "deleted by us" - UA -> "added by them" - UD -> "deleted by them" - UU -> "both modified" - -data GitVersion - = GitVersion Int Int Int - deriving stock (Eq, Ord) - -showGitVersion :: GitVersion -> Text -showGitVersion (GitVersion x y z) = - Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z) - --- | Apply stash, return conflicts. -gitApplyStash :: Text -> IO [GitConflict] -gitApplyStash stash = do - conflicts <- - git ["stash", "apply", stash] >>= \case - False -> gitConflicts - True -> pure [] - gitUnstageChanges - pure conflicts - -gitCommit :: IO Bool -gitCommit = - queryTerminal 0 >>= \case - False -> do - message <- lookupEnv "MIT_COMMIT_MESSAGE" - git ["commit", "--all", "--message", maybe "" Text.pack message] - True -> - git2 ["commit", "--patch", "--quiet"] <&> \case - ExitFailure _ -> False - ExitSuccess -> True - -gitCommitsBetween :: Maybe Text -> Text -> IO [GitCommitInfo] -gitCommitsBetween commit1 commit2 = - if commit1 == Just commit2 - then pure [] - else do - commits <- - -- --first-parent seems desirable for topic branches - git - [ "rev-list", - "--color=always", - "--date=human", - "--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s", - "--max-count=10", - maybe id (\c1 c2 -> c1 <> ".." <> c2) commit1 commit2 - ] - pure (map parseCommitInfo (dropEvens commits)) - where - -- git rev-list with a custom format prefixes every commit with a redundant line :| - dropEvens :: [a] -> [a] - dropEvens = \case - _ : x : xs -> x : 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) - -gitCreateStash :: IO Text -gitCreateStash = do - git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed - stash <- git ["stash", "create"] - gitUnstageChanges - pure stash - --- | Get the current branch. -gitCurrentBranch :: IO Text -gitCurrentBranch = - git ["branch", "--show-current"] - --- FIXME document this -gitDiff :: IO DiffResult -gitDiff = do - gitUnstageChanges - git ["diff", "--quiet"] <&> \case - False -> Differences - True -> NoDifferences - --- | Do any untracked files exist? -gitExistUntrackedFiles :: IO Bool -gitExistUntrackedFiles = - not . null <$> gitListUntrackedFiles - -gitConflicts :: IO [GitConflict] -gitConflicts = - mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"] - --- | List all untracked files. -gitListUntrackedFiles :: IO [Text] -gitListUntrackedFiles = - git ["ls-files", "--exclude-standard", "--other"] - --- FIXME document what this does -gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ()) -gitMerge me target = do - git ["merge", "--ff", "--no-commit", target] >>= \case - False -> - (pure . Left) do - conflicts <- gitConflicts - git_ ["add", "--all"] - git_ ["commit", "--no-edit", "--message", mergeMessage conflicts] - pure conflicts - True -> do - whenM gitMergeInProgress (git_ ["commit", "--message", mergeMessage []]) - pure (Right ()) - where - mergeMessage :: [GitConflict] -> Text - mergeMessage conflicts = - -- FIXME use builder - fold - [ "⅄", - if null conflicts then "" else "\x0338", - " ", - if target' == me then me else target' <> " → " <> me, - if null conflicts - then "" - else - " (conflicts)\n\nConflicting files:\n" - <> Text.intercalate "\n" (map ((" " <>) . showGitConflict) conflicts) - ] - where - target' :: Text - target' = - fromMaybe target (Text.stripPrefix "origin/" target) - -gitMergeInProgress :: IO Bool -gitMergeInProgress = - doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD")) - -gitPush :: Text -> IO Bool -gitPush branch = - git ["push", "--set-upstream", "origin", branch <> ":" <> branch] - --- | Blow away untracked files, and hard-reset to the given commit -gitResetHard :: Text -> IO () -gitResetHard commit = do - git_ ["clean", "-d", "--force"] - git ["reset", "--hard", commit] - --- | Create a stash and blow away local changes (like 'git stash push') -gitStash :: IO Text -gitStash = do - stash <- gitCreateStash - gitResetHard "HEAD" - pure stash - -gitUnstageChanges :: IO () -gitUnstageChanges = do - git_ ["reset"] - untrackedFiles <- gitListUntrackedFiles - unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles)) - -gitVersion :: IO GitVersion -gitVersion = do - v0 <- git ["--version"] - fromMaybe (throwIO (userError ("Could not parse git version from: " <> Text.unpack v0))) do - ["git", "version", v1] <- Just (Text.words v0) - [sx, sy, sz] <- Just (Text.split (== '.') v1) - x <- readMaybe (Text.unpack sx) - y <- readMaybe (Text.unpack sy) - z <- readMaybe (Text.unpack sz) - pure (pure (GitVersion x y z)) - --- /dir/one 0efd393c35 [oingo] -> ("/dir/one", "0efd393c35", Just "oingo") --- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing) -gitWorktreeList :: IO [(Text, Text, Maybe Text)] -gitWorktreeList = do - map f <$> git ["worktree", "list"] - where - f :: Text -> (Text, Text, Maybe Text) - f line = - case Text.words line of - [dir, commit, stripBrackets -> Just branch] -> (dir, commit, Just branch) - [dir, commit, "(detached", "HEAD)"] -> (dir, commit, Nothing) - _ -> error (Text.unpack line) - where - stripBrackets :: Text -> Maybe Text - stripBrackets = - Text.stripPrefix "[" >=> Text.stripSuffix "]" - --- git@github.com:mitchellwrosen/mit.git -> Just ("git@github.com:mitchellwrosen/mit.git", "mit") -parseGitRepo :: Text -> Maybe (Text, Text) -parseGitRepo url = do - url' <- Text.stripSuffix ".git" url - pure (url, Text.takeWhileEnd (/= '/') url') - --- Some ad-hoc process return value overloading, for cleaner syntax - -class ProcessOutput a where - fromProcessOutput :: [Text] -> [Text] -> ExitCode -> IO a - -instance ProcessOutput () where - fromProcessOutput _ _ code = - when (code /= ExitSuccess) (exitWith code) - -instance ProcessOutput Bool where - fromProcessOutput _ _ = \case - ExitFailure _ -> pure False - ExitSuccess -> pure True - -instance ProcessOutput Text where - fromProcessOutput out _ code = do - when (code /= ExitSuccess) (exitWith code) - case out of - [] -> throwIO (userError "no stdout") - line : _ -> pure line - -instance a ~ Text => ProcessOutput [a] where - fromProcessOutput out _ code = do - when (code /= ExitSuccess) (exitWith code) - pure out - -instance a ~ ExitCode => ProcessOutput (Either a Text) where - fromProcessOutput out _ code = - case code of - ExitFailure _ -> pure (Left code) - ExitSuccess -> - case out of - [] -> throwIO (userError "no stdout") - line : _ -> pure (Right line) - --- - -git :: ProcessOutput a => [Text] -> IO a -git args = do - (Nothing, Just stdoutHandle, Just stderrHandle, processHandle) <- - createProcess - CreateProcess - { child_group = Nothing, - child_user = Nothing, - close_fds = True, - cmdspec = RawCommand "git" (map Text.unpack args), - create_group = False, - cwd = Nothing, - delegate_ctlc = False, - env = Nothing, - new_session = False, - std_err = CreatePipe, - std_in = NoStream, - std_out = CreatePipe, - -- windows-only - create_new_console = False, - detach_console = False, - use_process_jobs = False - } - exitCode <- waitForProcess processHandle - stdoutLines <- drainTextHandle stdoutHandle - stderrLines <- drainTextHandle stderrHandle - debugPrintGit args stdoutLines stderrLines exitCode - fromProcessOutput stdoutLines stderrLines exitCode - -git_ :: [Text] -> IO () -git_ = - git - --- Yucky interactive/inherity variant (so 'git commit' can open an editor). -git2 :: [Text] -> IO ExitCode -git2 args = do - (Nothing, Nothing, Just stderrHandle, processHandle) <- - createProcess - CreateProcess - { child_group = Nothing, - child_user = Nothing, - close_fds = True, - cmdspec = RawCommand "git" (map Text.unpack args), - create_group = False, - cwd = Nothing, - delegate_ctlc = True, - env = Nothing, - new_session = False, - std_err = CreatePipe, - std_in = Inherit, - std_out = Inherit, - -- windows-only - create_new_console = False, - detach_console = False, - use_process_jobs = False - } - exitCode <- - waitForProcess processHandle `catch` \case - UserInterrupt -> pure (ExitFailure (-130)) - exception -> throwIO exception - stderrLines <- drainTextHandle stderrHandle - debugPrintGit args [] stderrLines exitCode - pure exitCode - -debugPrintGit :: [Text] -> [Text] -> [Text] -> ExitCode -> IO () -debugPrintGit args stdoutLines stderrLines exitCode = - when debug do - putLines do - Text.bold (Text.brightBlack (Text.unwords (marker <> " git" : map quoteText args))) - : map (Text.brightBlack . (" " <>)) (stdoutLines ++ stderrLines) - where - marker :: Text - marker = - case exitCode of - ExitFailure _ -> "✗" - ExitSuccess -> "✓" - --- Mini prelude extensions - -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = - flip fmap - -drainTextHandle :: Handle -> IO [Text] -drainTextHandle handle = do - let loop acc = - hIsEOF handle >>= \case - False -> do - line <- Text.hGetLine handle - loop (line : acc) - True -> pure (reverse acc) - loop [] - -putLines :: [Text] -> IO () -putLines = - Text.putStr . Text.unlines - -quoteText :: Text -> Text -quoteText s = - if Text.any isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s - -unlessM :: Monad m => m Bool -> m () -> m () -unlessM mx action = - mx >>= \case - False -> action - True -> pure () - -whenM :: Monad m => m Bool -> m () -> m () -whenM mx action = - mx >>= \case - False -> pure () - True -> action diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import qualified Mit +import Prelude + +main :: IO () +main = + Mit.main diff --git a/mit-3qvpPyAi6mH.cabal b/mit-3qvpPyAi6mH.cabal --- a/mit-3qvpPyAi6mH.cabal +++ b/mit-3qvpPyAi6mH.cabal @@ -4,7 +4,6 @@ bug-reports: https://github.com/mitchellwrosen/mit/issues category: CLI copyright: Copyright (C) 2020 Mitchell Rosen -description: A git wrapper with a streamlined UX. homepage: https://github.com/mitchellwrosen/mit license: MIT license-file: LICENSE @@ -12,9 +11,17 @@ name: mit-3qvpPyAi6mH stability: experimental synopsis: A git wrapper with a streamlined UX -version: 2 +version: 3 -executable mit +description: + A git wrapper with a streamlined UX. + + To install the @mit@ command-line tool, run @cabal install mit-3qvpPyAi6mH@. + + This package's library component does not follow the Package Versioning Policy, and is only exposed for the test + suite. + +common component build-depends: base < 5, base64, @@ -29,6 +36,7 @@ default-extensions: BlockArguments DataKinds + DeriveFunctor DerivingStrategies DuplicateRecordFields FlexibleInstances @@ -37,12 +45,40 @@ MultiParamTypeClasses MultiWayIf NamedFieldPuns + NoImplicitPrelude NumericUnderscores OverloadedStrings ScopedTypeVariables + TupleSections TypeApplications UndecidableInstances ViewPatterns default-language: Haskell2010 ghc-options: -Wall + +library + import: component + exposed-modules: + Mit + Mit.Git + Mit.Globals + Mit.Prelude + Mit.Process + hs-source-dirs: src + +executable mit + import: component + build-depends: + mit-3qvpPyAi6mH, + 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 new file mode 100644 --- /dev/null +++ b/src/Mit.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +module Mit where + +import qualified Data.List.NonEmpty as List1 +import qualified Data.Text as Text +import qualified Data.Text.ANSI as Text +import qualified Data.Text.Encoding.Base64 as Text +import qualified Data.Text.IO as Text +import Mit.Git +import Mit.Prelude +import qualified System.Clock as Clock +import System.Directory (doesDirectoryExist, removeFile, withCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode (..), exitFailure) + +-- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit +-- ephemeral feeling +-- FIXME bail if active cherry-pick, active revert, active rebase, what else? +-- FIXME rev-list max 11, use ellipses after 10 +-- FIXME test file deleted by us/them conflict + +-- TODO mit init +-- TODO mit delete-branch +-- TODO tweak things to work with git < 2.30.1 +-- TODO rewrite mit commit algorithm in readme +-- TODO git(hub,lab) flow or something? +-- TODO 'mit branch' with dirty working directory - apply changes to new worktree? +-- TODO undo in more cases? +-- TODO recommend merging master if it conflicts +-- TODO mit log +-- TODO optparse-applicative + +main :: IO () +main = do + getArgs >>= \case + ["branch", branch] -> mitBranch (Text.pack branch) + ["clone", parseGitRepo . Text.pack -> Just (url, name)] -> mitClone url name + ["commit"] -> mitCommit + ["merge", branch] -> mitMerge (Text.pack branch) + ["sync"] -> mitSync + ["undo"] -> mitUndo + _ -> do + putLines + [ "Usage:", + " mit branch ≪branch≫", + " mit clone ≪repo≫", + " mit commit", + " mit merge ≪branch≫", + " mit sync", + " mit undo" + ] + exitFailure + +dieIfBuggyGit :: IO () +dieIfBuggyGit = do + version <- gitVersion + case foldr (\(ver, err) acc -> if version < ver then (ver, err) : acc else acc) [] validations of + [] -> pure () + errors -> + die $ + map + (\(ver, err) -> "Prior to " <> Text.bold "git" <> " version " <> showGitVersion ver <> ", " <> err) + errors + where + validations :: [(GitVersion, Text)] + validations = + [ ( GitVersion 2 29 0, + Text.bold "git commit --patch" + <> " was broken for new files added with " + <> Text.bold "git add --intent-to-add" + <> "." + ), + ( GitVersion 2 30 1, + Text.bold "git stash create" + <> " was broken for new files added with " + <> Text.bold "git add --intent-to-add" + <> "." + ) + ] + +dieIfMergeInProgress :: IO () +dieIfMergeInProgress = + whenM gitMergeInProgress (die [Text.bold "git merge" <> " in progress."]) + +dieIfNotInGitDir :: IO () +dieIfNotInGitDir = + try (evaluate gitdir) >>= \case + Left (_ :: ExitCode) -> exitFailure + Right _ -> pure () + +die :: [Text] -> IO a +die ss = do + Text.putStr (Text.red (Text.unlines ss)) + exitFailure + +mitBranch :: Text -> IO () +mitBranch branch = do + dieIfNotInGitDir + + gitBranchWorktreeDir branch >>= \case + Nothing -> + doesDirectoryExist (Text.unpack worktreeDir) >>= \case + False -> do + git_ ["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 + git_ ["reset", "--hard", upstream] + git_ ["branch", "--set-upstream-to", upstream] + True -> gitSwitch branch + True -> die ["Directory " <> Text.bold worktreeDir <> " already exists."] + Just directory -> + unless (directory == worktreeDir) do + die [Text.bold branch <> " is already checked out in " <> Text.bold directory <> "."] + where + worktreeDir :: Text + worktreeDir = + Text.dropWhileEnd (/= '/') gitdir <> branch + +mitClone :: Text -> Text -> IO () +mitClone url name = + -- FIXME use 'git config --get init.defaultBranch' + git ["clone", url, "--separate-git-dir", name <> "/.git", name <> "/master"] + +mitCommit :: IO () +mitCommit = do + dieIfNotInGitDir + whenM gitExistUntrackedFiles dieIfBuggyGit + gitDiff >>= \case + Differences -> + gitMergeInProgress >>= \case + False -> mitCommit_ + True -> mitCommitMerge + NoDifferences -> exitFailure + +mitCommit_ :: IO () +mitCommit_ = do + fetched <- gitFetch "origin" + branch <- gitCurrentBranch + let branch64 = Text.encodeBase64 branch + head <- gitHead + maybeUpstreamHead <- gitRemoteBranchHead "origin" branch + existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head) maybeUpstreamHead + existLocalCommits <- maybe (pure True) (\upstreamHead -> gitExistCommitsBetween upstreamHead "HEAD") maybeUpstreamHead + state0 <- readMitState branch64 + + let wouldFork = existRemoteCommits && not existLocalCommits + let shouldWarnAboutFork = + case wouldFork of + False -> pure False + True -> 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 + + -- Bail out early if we should warn that this commit would fork history + whenM shouldWarnAboutFork do + ranCommitAt <- Just . Clock.toNanoSecs <$> Clock.getTime Clock.Realtime + writeMitState branch64 state0 {ranCommitAt} + putLines + [ "", + " " <> 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.", + "" + ] + exitFailure + + stash <- gitCreateStash + committed <- gitCommit + localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD" + + pushResult <- + case (localCommits, existRemoteCommits, fetched) of + ([], _, _) -> pure (PushNotAttempted NothingToPush) + (_ : _, True, _) -> pure (PushNotAttempted ForkedHistory) + (_ : _, False, False) -> pure (PushNotAttempted Offline) + (_ : _, 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 . Clock.toNanoSecs <$> Clock.getTime Clock.Realtime + _ -> pure Nothing + + undos <- + case (pushed, committed, localCommits) of + (False, False, _) -> pure state0.undos + (False, True, _) -> pure [Reset head, Apply stash] + (True, True, [_]) -> do + head1 <- gitHead + pure [Revert head1, Apply stash] + (True, _, _) -> pure [] + + writeMitState branch64 MitState {head = (), merging = Nothing, ranCommitAt, undos} + + putSummary + Summary + { branch, + -- Whether 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. + canUndo = not (null undos) && committed, + conflicts = [], + syncs = + case List1.nonEmpty localCommits of + Nothing -> [] + Just commits -> + [ Sync + { commits, + result = pushResultToSyncResult pushResult, + source = branch, + target = "origin/" <> branch + } + ] + } + +mitCommitMerge :: IO () +mitCommitMerge = do + branch <- gitCurrentBranch + let branch64 = Text.encodeBase64 branch + head <- gitHead + state0 <- readMitState branch64 + + case state0.merging of + Nothing -> git_ ["commit", "--all", "--no-edit"] + Just merging -> + let message = fold ["⅄ ", if merging == branch then "" else merging <> " → ", branch] + in git_ ["commit", "--all", "--message", message] + case listToMaybe [commit | Apply commit <- state0.undos] of + Nothing -> mitSyncWith (Just [Reset head]) + Just stash -> + gitApplyStash stash >>= \case + -- FIXME we just unstashed, now we're about to stash again :/ + [] -> mitSyncWith (Just [Reset head, Apply stash]) + conflicts -> do + writeMitState branch64 state0 {merging = Nothing, ranCommitAt = Nothing} + putSummary + Summary + { branch, + canUndo = not (null state0.undos), + conflicts, + syncs = [] + } + +data PushResult + = PushAttempted Bool + | PushNotAttempted PushNotAttemptedReason + +data PushNotAttemptedReason + = ForkedHistory -- local history has forked, need to sync + | NothingToPush -- no commits to push + | 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 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 + + -- 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) + + maybeMergeStatus <- mitMerge' ("⅄ " <> target <> " → " <> branch) targetCommit + + writeMitState + branch64 + MitState + { head = (), + merging = do + mergeStatus <- maybeMergeStatus + case mergeStatus.result of + MergeResult'MergeConflicts _ -> Just target + MergeResult'StashConflicts _ -> Nothing, + ranCommitAt = Nothing, + undos = + case maybeMergeStatus of + Nothing -> [] + Just mergeStatus -> mergeStatus.undos + } + + putSummary + Summary + { branch, + canUndo = isJust maybeMergeStatus, + conflicts = + case maybeMergeStatus of + Nothing -> [] + Just mergeStatus -> + case mergeStatus.result of + MergeResult'MergeConflicts conflicts -> List1.toList conflicts + MergeResult'StashConflicts conflicts -> conflicts, + syncs = do + mergeStatus <- maybeToList maybeMergeStatus + pure + Sync + { commits = mergeStatus.commits, + result = + case mergeStatus.result of + MergeResult'MergeConflicts _ -> SyncResult'Failure + -- Even if we have conflicts from unstashing, we call this merge a success. + MergeResult'StashConflicts _ -> SyncResult'Success, + source = target, + target = branch + } + } + +data MergeStatus = MergeStatus + { commits :: List1 GitCommitInfo, + result :: MergeResult, + undos :: [Undo] -- FIXME List1 + } + +data MergeResult + = MergeResult'MergeConflicts (List1 GitConflict) + | MergeResult'StashConflicts [GitConflict] + +mitMerge' :: Text -> Text -> IO (Maybe MergeStatus) +mitMerge' message target = do + head <- gitHead + (List1.nonEmpty <$> 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 + pure (MergeResult'MergeConflicts (List1.fromList conflicts)) + True -> do + whenM gitMergeInProgress (git_ ["commit", "--message", message]) + maybeConflicts <- for maybeStash gitApplyStash + pure (MergeResult'StashConflicts (fromMaybe [] maybeConflicts)) + 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 + dieIfNotInGitDir + dieIfMergeInProgress + whenM gitExistUntrackedFiles dieIfBuggyGit + mitSyncWith Nothing + +-- | @mitSyncWith maybeUndos@ +-- +-- Whenever recording what 'mit undo' should do after 'mit sync', if 'maybeUndos' is provided, we use them instead. +-- This is pulled into a function argument to get better undo behavior after committing a merge. +-- +-- Consider: +-- +-- The user runs 'mit merge foo' (with or without a clean working tree), and gets conflicts. After fixing them, she runs +-- 'mit commit'. This may result in *additional* conflicts due to the just-stashed uncommitted changes. +-- +-- But either way, internally, we would like this 'mit commit' to effectively behave as a normal commit, in the sense +-- that we want to immediately push it upstream. That means the code would like to simply call 'mit sync' after +-- 'git commit'! +-- +-- However, if this commit could be undone (i.e. we didn't push it), we wouldn't want that 'mit sync' to *locally* +-- compute where to undo, because it would just conclude, "oh, HEAD hasn't moved, and we didn't push, so there's nothing +-- to undo". +-- +-- 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 [Undo] -> IO () +mitSyncWith maybeUndos = do + fetched <- gitFetch "origin" + branch <- gitCurrentBranch + let branch64 = Text.encodeBase64 branch + maybeUpstreamHead <- gitRemoteBranchHead "origin" branch + + maybeMergeStatus <- + case maybeUpstreamHead of + Nothing -> pure Nothing + Just upstreamHead -> mitMerge' ("⅄ " <> branch) upstreamHead + + localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD" + + pushResult <- + case (localCommits, (.result) <$> maybeMergeStatus, fetched) of + ([], _, _) -> pure (PushNotAttempted NothingToPush) + -- "forked history" is ok - a bit different than history *already* having forked, in which case a push + -- would just fail, whereas this is just us choosing not to push while in the middle of a merge due to a + -- previous fork in the history + (_ : _, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory) + (_ : _, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits) + (_ : _, Nothing, False) -> pure (PushNotAttempted Offline) + (_ : _, Nothing, True) -> PushAttempted <$> gitPush branch + + let pushed = + case pushResult of + PushAttempted success -> success + PushNotAttempted _ -> False + + let undos = + case pushed of + False -> fromMaybe (maybe [] (.undos) maybeMergeStatus) maybeUndos + True -> [] + + writeMitState + branch64 + MitState + { head = (), + merging = do + mergeStatus <- maybeMergeStatus + case mergeStatus.result of + MergeResult'MergeConflicts _ -> Just branch + MergeResult'StashConflicts _ -> Nothing, + ranCommitAt = Nothing, + undos + } + + putSummary + Summary + { branch, + canUndo = not (null undos), + conflicts = + case maybeMergeStatus of + Nothing -> [] + Just mergeStatus -> + case mergeStatus.result of + MergeResult'MergeConflicts conflicts -> List1.toList conflicts + MergeResult'StashConflicts conflicts -> conflicts, + syncs = + catMaybes + [ do + mergeStatus <- maybeMergeStatus + pure + Sync + { commits = mergeStatus.commits, + result = + case mergeStatus.result of + MergeResult'MergeConflicts _ -> SyncResult'Failure + MergeResult'StashConflicts _ -> SyncResult'Success, + source = "origin/" <> branch, + target = branch + }, + do + commits <- List1.nonEmpty localCommits + pure + Sync + { commits, + result = pushResultToSyncResult pushResult, + source = branch, + target = "origin/" <> branch + } + ] + } + +-- FIXME output what we just undid +mitUndo :: IO () +mitUndo = do + dieIfNotInGitDir + + branch64 <- Text.encodeBase64 <$> gitCurrentBranch + state0 <- readMitState branch64 + case List1.nonEmpty state0.undos of + Nothing -> exitFailure + Just undos1 -> applyUndos undos1 + when (undosContainRevert state0.undos) mitSync + where + undosContainRevert :: [Undo] -> Bool + undosContainRevert = \case + [] -> False + Revert _ : _ -> True + _ : undos -> undosContainRevert undos + +data Summary = Summary + { branch :: Text, + canUndo :: Bool, + conflicts :: [GitConflict], + syncs :: [Sync] + } + +data Sync = Sync + { commits :: List1 GitCommitInfo, + result :: SyncResult, + source :: Text, + target :: Text + } + +data SyncResult + = SyncResult'Failure + | SyncResult'Offline + | SyncResult'Pending + | SyncResult'Success + +-- FIXME show some graph of where local/remote is at +putSummary :: Summary -> IO () +putSummary summary = + let output = concatMap syncLines summary.syncs ++ conflictsLines ++ undoLines + in if null output then pure () else putLines ("" : output) + where + conflictsLines :: [Text] + conflictsLines = + if null summary.conflicts + then [] + else + " The following files have conflicts." : + map ((" " <>) . Text.red . showGitConflict) summary.conflicts ++ [""] + syncLines :: Sync -> [Text] + syncLines sync = + colorize (Text.italic (" " <> sync.source <> " → " <> sync.target)) : + map ((" " <>) . prettyGitCommitInfo) (List1.toList sync.commits) + ++ [""] + where + colorize :: Text -> Text + colorize = + case sync.result of + SyncResult'Failure -> Text.red + SyncResult'Offline -> Text.brightBlack + SyncResult'Pending -> Text.yellow + SyncResult'Success -> Text.green + undoLines :: [Text] + undoLines = + if summary.canUndo + then [" Run " <> Text.bold (Text.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/Git.hs b/src/Mit/Git.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Git.hs @@ -0,0 +1,429 @@ +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +module Mit.Git where + +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.ANSI as Text +import Mit.Globals (debug) +import Mit.Prelude +import Mit.Process +import System.Directory (doesFileExist) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Terminal (queryTerminal) +import System.Process + +-- FIXME this finds the wrong dir for worktrees +gitdir :: Text +gitdir = + unsafePerformIO (git ["rev-parse", "--absolute-git-dir"]) +{-# NOINLINE gitdir #-} + +data DiffResult + = Differences + | NoDifferences + +data GitCommitInfo = GitCommitInfo + { author :: Text, + date :: Text, + hash :: Text, + shorthash :: Text, + subject :: Text + } + deriving stock (Show) + +prettyGitCommitInfo :: GitCommitInfo -> Text +prettyGitCommitInfo info = + -- FIXME use builder + fold + [ Text.bold (Text.black info.shorthash), + " ", + Text.bold (Text.white info.subject), + " - ", + Text.italic (Text.white info.author), + " ", + Text.italic (Text.yellow info.date) -- FIXME some other color, magenta? + ] + +data GitConflict + = GitConflict GitConflictXY Text + deriving stock (Eq, Show) + +parseGitConflict :: Text -> Maybe GitConflict +parseGitConflict line = do + [xy, name] <- Just (Text.words line) + GitConflict <$> parseGitConflictXY xy <*> Just name + +-- FIXME builder +showGitConflict :: GitConflict -> Text +showGitConflict (GitConflict xy name) = + name <> " (" <> showGitConflictXY xy <> ")" + +data GitConflictXY + = AA -- both added + | AU -- added by us + | DD -- both deleted + | DU -- deleted by us + | UA -- added by them + | UD -- deleted by them + | UU -- both modified + deriving stock (Eq, Show) + +parseGitConflictXY :: Text -> Maybe GitConflictXY +parseGitConflictXY = \case + "AA" -> Just AA + "AU" -> Just AU + "DD" -> Just DD + "DU" -> Just DU + "UA" -> Just UA + "UD" -> Just UD + "UU" -> Just UU + _ -> Nothing + +-- FIXME builder +showGitConflictXY :: GitConflictXY -> Text +showGitConflictXY = \case + AA -> "both added" + AU -> "added by us" + DD -> "both deleted" + DU -> "deleted by us" + UA -> "added by them" + UD -> "deleted by them" + UU -> "both modified" + +data GitVersion + = GitVersion Int Int Int + deriving stock (Eq, Ord) + +showGitVersion :: GitVersion -> Text +showGitVersion (GitVersion x y z) = + Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z) + +-- | Apply stash, return conflicts. +gitApplyStash :: Text -> IO [GitConflict] +gitApplyStash stash = do + conflicts <- + git ["stash", "apply", stash] >>= \case + False -> gitConflicts + True -> pure [] + gitUnstageChanges + pure conflicts + +-- | Create a branch. +gitBranch :: Text -> IO () +gitBranch branch = + git_ ["branch", "--no-track", branch] + +-- | Does the given local branch (refs/heads/...) exist? +gitBranchExists :: Text -> IO Bool +gitBranchExists branch = + git ["rev-parse", "--verify", "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 + Left _ -> Nothing + Right head -> Just head + +-- | Get the directory a branch's worktree is checked out in, if it exists. +gitBranchWorktreeDir :: Text -> IO (Maybe Text) +gitBranchWorktreeDir branch = do + worktrees <- gitWorktreeList + case List.find (\worktree -> worktree.branch == Just branch) worktrees of + Nothing -> pure Nothing + Just worktree -> pure (Just worktree.directory) + +gitCommit :: IO Bool +gitCommit = + queryTerminal 0 >>= \case + False -> do + message <- lookupEnv "MIT_COMMIT_MESSAGE" + git ["commit", "--all", "--message", maybe "" Text.pack message] + True -> + git2 ["commit", "--patch", "--quiet"] <&> \case + ExitFailure _ -> False + ExitSuccess -> True + +gitCommitsBetween :: Maybe Text -> Text -> IO [GitCommitInfo] +gitCommitsBetween commit1 commit2 = + if commit1 == Just commit2 + then pure [] + else do + commits <- + -- --first-parent seems desirable for topic branches + git + [ "rev-list", + "--color=always", + "--date=human", + "--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s", + "--max-count=10", + maybe id (\c1 c2 -> c1 <> ".." <> c2) commit1 commit2 + ] + pure (map parseCommitInfo (dropEvens commits)) + where + -- git rev-list with a custom format prefixes every commit with a redundant line :| + dropEvens :: [a] -> [a] + dropEvens = \case + _ : x : xs -> x : 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"] + +gitCreateStash :: IO Text +gitCreateStash = do + git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed + stash <- git ["stash", "create"] + gitUnstageChanges + pure stash + +-- | Get the current branch. +gitCurrentBranch :: IO Text +gitCurrentBranch = + git ["branch", "--show-current"] + +-- FIXME document this +gitDiff :: IO DiffResult +gitDiff = do + gitUnstageChanges + git ["diff", "--quiet"] <&> \case + False -> Differences + True -> NoDifferences + +gitExistCommitsBetween :: Text -> Text -> IO Bool +gitExistCommitsBetween commit1 commit2 = + if commit1 == commit2 + then pure False + else isJust <$> git ["rev-list", "--max-count=1", commit1 <> ".." <> commit2] + +-- | Do any untracked files exist? +gitExistUntrackedFiles :: IO Bool +gitExistUntrackedFiles = + not . null <$> gitListUntrackedFiles + +gitFetch :: Text -> IO Bool +gitFetch remote = + git ["fetch", remote] + +gitFetch_ :: Text -> IO () +gitFetch_ = + void . gitFetch + +gitHead :: IO Text +gitHead = + git ["rev-parse", "HEAD"] + +-- | List all untracked files. +gitListUntrackedFiles :: IO [Text] +gitListUntrackedFiles = + git ["ls-files", "--exclude-standard", "--other"] + +-- FIXME document what this does +gitMerge :: Text -> Text -> IO (Either (IO [GitConflict]) ()) +gitMerge me target = do + git ["merge", "--ff", "--no-commit", target] >>= \case + False -> + (pure . Left) do + conflicts <- gitConflicts + git_ ["add", "--all"] + git_ ["commit", "--no-edit", "--message", mergeMessage conflicts] + pure conflicts + True -> do + whenM gitMergeInProgress (git_ ["commit", "--message", mergeMessage []]) + pure (Right ()) + where + mergeMessage :: [GitConflict] -> Text + mergeMessage conflicts = + -- FIXME use builder + fold + [ "⅄", + if null conflicts then "" else "\x0338", + " ", + if target' == me then me else target' <> " → " <> me, + if null conflicts + then "" + else + " (conflicts)\n\nConflicting files:\n" + <> Text.intercalate "\n" (map ((" " <>) . showGitConflict) conflicts) + ] + where + target' :: Text + target' = + fromMaybe target (Text.stripPrefix "origin/" target) + +gitMergeInProgress :: IO Bool +gitMergeInProgress = + doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD")) + +gitPush :: Text -> IO Bool +gitPush branch = + git ["push", "--set-upstream", "origin", branch <> ":" <> branch] + +-- | Does the given remote branch (refs/remotes/...) exist? +gitRemoteBranchExists :: Text -> Text -> IO Bool +gitRemoteBranchExists remote branch = + git ["rev-parse", "--verify", "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 + Left _ -> Nothing + Right head -> Just head + +-- | Blow away untracked files, and hard-reset to the given commit +gitResetHard :: Text -> IO () +gitResetHard commit = do + git_ ["clean", "-d", "--force"] + git ["reset", "--hard", commit] + +gitRevert :: Text -> IO () +gitRevert commit = + git_ ["revert", commit] + +-- | Stash uncommitted changes (if any). +gitStash :: IO (Maybe Text) +gitStash = do + gitDiff >>= \case + Differences -> do + stash <- gitCreateStash + gitResetHard "HEAD" + pure (Just stash) + NoDifferences -> pure Nothing + +gitSwitch :: Text -> IO () +gitSwitch branch = + git_ ["switch", branch] + +gitUnstageChanges :: IO () +gitUnstageChanges = do + git_ ["reset", "--mixed"] + untrackedFiles <- gitListUntrackedFiles + unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles)) + +gitVersion :: IO GitVersion +gitVersion = do + v0 <- git ["--version"] + fromMaybe (throwIO (userError ("Could not parse git version from: " <> Text.unpack v0))) do + ["git", "version", v1] <- Just (Text.words v0) + [sx, sy, sz] <- Just (Text.split (== '.') v1) + x <- readMaybe (Text.unpack sx) + y <- readMaybe (Text.unpack sy) + z <- readMaybe (Text.unpack sz) + pure (pure (GitVersion x y z)) + +data GitWorktree = GitWorktree + { branch :: Maybe Text, + commit :: Text, + directory :: Text + } + +-- /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"] + 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) + where + stripBrackets :: Text -> Maybe Text + stripBrackets = + Text.stripPrefix "[" >=> Text.stripSuffix "]" + +-- git@github.com:mitchellwrosen/mit.git -> Just ("git@github.com:mitchellwrosen/mit.git", "mit") +parseGitRepo :: Text -> Maybe (Text, Text) +parseGitRepo url = do + url' <- Text.stripSuffix ".git" url + pure (url, Text.takeWhileEnd (/= '/') url') + +git :: ProcessOutput a => [Text] -> IO a +git args = do + (Nothing, Just stdoutHandle, Just stderrHandle, processHandle) <- + createProcess + CreateProcess + { child_group = Nothing, + child_user = Nothing, + close_fds = True, + cmdspec = RawCommand "git" (map Text.unpack args), + create_group = False, + cwd = Nothing, + delegate_ctlc = False, + env = Nothing, + new_session = False, + std_err = CreatePipe, + std_in = NoStream, + std_out = CreatePipe, + -- windows-only + create_new_console = False, + detach_console = False, + use_process_jobs = False + } + exitCode <- waitForProcess processHandle + stdoutLines <- drainTextHandle stdoutHandle + stderrLines <- drainTextHandle stderrHandle + debugPrintGit args stdoutLines stderrLines exitCode + fromProcessOutput stdoutLines stderrLines exitCode + +git_ :: [Text] -> IO () +git_ = + git + +-- Yucky interactive/inherity variant (so 'git commit' can open an editor). +git2 :: [Text] -> IO ExitCode +git2 args = do + (Nothing, Nothing, Just stderrHandle, processHandle) <- + createProcess + CreateProcess + { child_group = Nothing, + child_user = Nothing, + close_fds = True, + cmdspec = RawCommand "git" (map Text.unpack args), + create_group = False, + cwd = Nothing, + delegate_ctlc = True, + env = Nothing, + new_session = False, + std_err = CreatePipe, + std_in = Inherit, + std_out = Inherit, + -- windows-only + create_new_console = False, + detach_console = False, + use_process_jobs = False + } + exitCode <- + waitForProcess processHandle `catch` \case + UserInterrupt -> pure (ExitFailure (-130)) + exception -> throwIO exception + stderrLines <- drainTextHandle stderrHandle + debugPrintGit args [] stderrLines exitCode + pure exitCode + +debugPrintGit :: [Text] -> [Text] -> [Text] -> ExitCode -> IO () +debugPrintGit args stdoutLines stderrLines exitCode = + when debug do + putLines do + let output :: [Text] + output = + map (Text.brightBlack . (" " <>)) (stdoutLines ++ stderrLines) + Text.bold (Text.brightBlack (Text.unwords (marker <> " git" : map quoteText args))) : output + where + marker :: Text + marker = + case exitCode of + ExitFailure _ -> "✗" + ExitSuccess -> "✓" diff --git a/src/Mit/Globals.hs b/src/Mit/Globals.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Globals.hs @@ -0,0 +1,10 @@ +module Mit.Globals where + +import Mit.Prelude +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) + +debug :: Bool +debug = + isJust (unsafePerformIO (lookupEnv "debug")) +{-# NOINLINE debug #-} diff --git a/src/Mit/Prelude.hs b/src/Mit/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Prelude.hs @@ -0,0 +1,80 @@ +module Mit.Prelude + ( module Mit.Prelude, + module X, + ) +where + +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.Maybe as X +import Data.Text as X (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Traversable as X +import System.IO (Handle, hIsEOF) +import Text.Read as X (readMaybe) +import Prelude as X hiding (head, id) + +type List1 = + List1.NonEmpty + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = + flip fmap + +bug :: Text -> a +bug = + error . Text.unpack + +drainTextHandle :: Handle -> IO [Text] +drainTextHandle handle = do + let loop acc = + hIsEOF handle >>= \case + False -> do + line <- Text.hGetLine handle + loop (line : acc) + True -> pure (reverse acc) + loop [] + +-- FIXME make this faster +int2text :: Integer -> Text +int2text = + Text.pack . show + +putLines :: [Text] -> IO () +putLines = + Text.putStr . Text.unlines + +quoteText :: Text -> Text +quoteText s = + if Text.any isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s + +-- FIXME make this faster +text2int :: Text -> Maybe Integer +text2int = + readMaybe . Text.unpack + +onLeftM :: Monad m => (a -> m b) -> m (Either a b) -> m b +onLeftM mx my = + my >>= either mx pure + +onNothingM :: Monad m => m a -> m (Maybe a) -> m a +onNothingM mx my = + my >>= maybe mx pure + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM mx action = + mx >>= \case + False -> action + True -> pure () + +whenM :: Monad m => m Bool -> m () -> m () +whenM mx action = + mx >>= \case + False -> pure () + True -> action diff --git a/src/Mit/Process.hs b/src/Mit/Process.hs new file mode 100644 --- /dev/null +++ b/src/Mit/Process.hs @@ -0,0 +1,44 @@ +-- Some ad-hoc process return value overloading, for cleaner syntax + +module Mit.Process where + +import Mit.Prelude +import System.Exit (ExitCode (..), exitWith) + +class ProcessOutput a where + fromProcessOutput :: [Text] -> [Text] -> ExitCode -> IO a + +instance ProcessOutput () where + fromProcessOutput _ _ code = + when (code /= ExitSuccess) (exitWith code) + +instance ProcessOutput Bool where + fromProcessOutput _ _ = \case + ExitFailure _ -> pure False + ExitSuccess -> pure True + +instance ProcessOutput Text where + fromProcessOutput out _ code = do + when (code /= ExitSuccess) (exitWith code) + case out of + [] -> throwIO (userError "no stdout") + line : _ -> pure line + +instance a ~ Text => ProcessOutput [a] where + fromProcessOutput out _ code = do + when (code /= ExitSuccess) (exitWith code) + pure out + +instance a ~ ExitCode => ProcessOutput (Either a Text) where + fromProcessOutput out _ code = + case code of + ExitFailure _ -> pure (Left code) + ExitSuccess -> + case out of + [] -> throwIO (userError "no stdout") + line : _ -> pure (Right line) + +instance a ~ Text => ProcessOutput (Maybe a) where + fromProcessOutput out _ code = do + when (code /= ExitSuccess) (exitWith code) + pure (listToMaybe out) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,83 @@ +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)