mit-3qvpPyAi6mH (empty) → 1

raw patch · 3 files changed

+1051/−0 lines, 3 filesdep +basedep +base64dep +clock

Dependencies added: base, base64, clock, directory, process, record-dot-preprocessor, record-hasfield, text, text-ansi, unix

Files

• LICENSE +21/−0
• Main.hs +982/−0
• mit-3qvpPyAi6mH.cabal +48/−0

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Mitchell Rosen++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,982 @@+{-# 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", "--quiet", worktreeDir]+        withCurrentDirectory (Text.unpack worktreeDir) do+          git ["rev-parse", "--quiet", "--verify", "refs/heads/" <> branch] >>= \case+            False -> do+              git_ ["branch", "--no-track", branch]+              git_ ["switch", "--quiet", branch]++              _fetchResult :: Bool <-+                git ["fetch", "--quiet", "origin"]++              whenM (git ["rev-parse", "--quiet", "--verify", "refs/remotes/" <> upstream]) do+                git_ ["reset", "--hard", "--quiet", upstream]+                git_ ["branch", "--set-upstream-to", upstream]+            True ->+              git_ ["switch", "--quiet", 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 <-+    git ["stash", "create"]++  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", "--quiet", "--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 [Text] <-+    case targetCommits of+      [] -> pure Nothing+      _ ->+        fmap Just do+          gitMerge context.branch target >>= \case+            Left commitConflicts -> commitConflicts+            Right () -> pure []++  stashConflicts :: [Text] <-+    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,+        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 [Text] <-+    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 :: [Text] <-+    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,+        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 -> git_ ["stash", "apply", "--quiet", commit]+        Reset commit -> git_ ["reset", "--hard", "--quiet", 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", "--quiet", "origin"]+  pure+    Context+      { branch,+        branch64 = Text.encodeBase64 branch,+        dirty,+        fetchFailed,+        head,+        upstream = "origin/" <> branch+      }++data Summary = Summary+  { branch :: Text,+    canUndo :: Bool,+    conflicts :: [Text],+    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) 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 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 [Text]+gitApplyStash stash = do+  git ["stash", "apply", "--quiet", stash] >>= \case+    False -> do+      conflicts <- git ["diff", "--name-only", "--diff-filter=U"]+      git_ ["reset", "--quiet"] -- unmerged (weird) -> unstaged (normal)+      pure conflicts+    True -> pure []++gitCommit :: IO Bool+gitCommit =+  queryTerminal 0 >>= \case+    False -> do+      message <- lookupEnv "MIT_COMMIT_MESSAGE"+      git ["commit", "--all", "--message", maybe "" Text.pack message, "--quiet"]+    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)++-- | Get the current branch.+gitCurrentBranch :: IO Text+gitCurrentBranch =+  git ["branch", "--show-current"]++-- | Do any untracked files exist?+gitExistUntrackedFiles :: IO Bool+gitExistUntrackedFiles = do+  files :: [Text] <- git ["ls-files", "--exclude-standard", "--other"]+  pure (not (null files))++gitDiff :: IO DiffResult+gitDiff = do+  git_ ["reset", "--quiet"]+  git_ ["add", "--all", "--intent-to-add"]+  git ["diff", "--quiet"] <&> \case+    False -> Differences+    True -> NoDifferences++-- FIXME document what this does+gitMerge :: Text -> Text -> IO (Either (IO [Text]) ())+gitMerge me target = do+  git ["merge", "--ff", "--no-commit", "--quiet", target] >>= \case+    False ->+      (pure . Left) do+        conflicts <- git ["diff", "--name-only", "--diff-filter=U"]+        git_ ["add", "--all"]+        git_ ["commit", "--no-edit", "--quiet", "--message", mergeMessage conflicts]+        pure conflicts+    True -> do+      whenM gitMergeInProgress (git_ ["commit", "--message", mergeMessage []])+      pure (Right ())+  where+    mergeMessage :: [Text] -> 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 ("  " <>) 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", "--quiet", "--set-upstream", "origin", branch <> ":" <> branch]++-- | Create a stash and blow away local changes (like 'git stash push')+gitStash :: IO Text+gitStash = do+  stash <- git ["stash", "create"]+  git_ ["reset", "--hard", "--quiet", "HEAD"]+  pure stash++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+  when debug do+    Text.putStrLn . Text.brightBlack $+      Text.unwords ("git" : map quoteText args)+        <> " : "+        <> Text.pack (show (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+  when debug do+    let quote :: Text -> Text+        quote s =+          if Text.any isSpace s then "'" <> Text.replace "'" "\\'" s <> "'" else s+    Text.putStrLn (Text.brightBlack (Text.unwords ("git" : map quote args)))+  (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+  when debug do+    Text.putStrLn . Text.brightBlack $+      Text.unwords ("git" : map quoteText args) <> " : " <> Text.pack (show (stderrLines, exitCode))+  pure exitCode++-- 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

@@ -0,0 +1,48 @@+cabal-version: 3.0++author: Mitchell Rosen+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+maintainer: Mitchell Rosen <mitchellwrosen@gmail.com>+name: mit-3qvpPyAi6mH+stability: experimental+synopsis: A git wrapper with a streamlined UX+version: 1++executable mit+  build-depends:+    base < 5,+    base64,+    clock,+    directory,+    process,+    record-dot-preprocessor,+    record-hasfield,+    text,+    text-ansi,+    unix,+  default-extensions:+    BlockArguments+    DataKinds+    DerivingStrategies+    DuplicateRecordFields+    FlexibleInstances+    GADTs+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NamedFieldPuns+    NumericUnderscores+    OverloadedStrings+    ScopedTypeVariables+    TypeApplications+    UndecidableInstances+    ViewPatterns+  default-language: Haskell2010+  ghc-options: -Wall -with-rtsopts=-N1+  main-is: Main.hs