packages feed

mit-3qvpPyAi6mH 5 → 6

raw patch · 9 files changed

+250/−209 lines, 9 files

Files

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