packages feed

mit-3qvpPyAi6mH 2 → 3

raw patch · 9 files changed

+1353/−1069 lines, 9 filesdep +freedep +mit-3qvpPyAi6mHdep +temporary

Dependencies added: free, mit-3qvpPyAi6mH, temporary

Files

− Main.hs 
@@ -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
+ app/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified Mit+import Prelude++main :: IO ()+main =+  Mit.main
mit-3qvpPyAi6mH.cabal view
@@ -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
+ src/Mit.hs view
@@ -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
+ src/Mit/Git.hs view
@@ -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 -> "✓"
+ src/Mit/Globals.hs view
@@ -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 #-}
+ src/Mit/Prelude.hs view
@@ -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
+ src/Mit/Process.hs view
@@ -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)
+ test/Main.hs view
@@ -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)