{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
module Mit where
import qualified Data.List.NonEmpty as List1
import qualified Data.Sequence as Seq
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 Mit.Seq1 as Seq1
import qualified System.Clock as Clock
import System.Directory (doesDirectoryExist, removeFile, withCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (ExitCode (..), exitFailure)
main :: IO ()
main :: IO ()
main = do
IO [String]
getArgs IO [String] -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[String
"branch", String
branch] -> Text -> IO ()
mitBranch (String -> Text
Text.pack String
branch)
[String
"commit"] -> IO ()
mitCommit
[String
"merge", String
branch] -> Text -> IO ()
mitMerge (String -> Text
Text.pack String
branch)
[String
"sync"] -> IO ()
mitSync
[String
"undo"] -> IO ()
mitUndo
[String]
_ -> do
[Text] -> IO ()
putLines
[ Text
"Usage:",
Text
" mit branch ≪branch≫",
Text
" mit clone ≪repo≫",
Text
" mit commit",
Text
" mit merge ≪branch≫",
Text
" mit sync",
Text
" mit undo"
]
IO ()
forall a. IO a
exitFailure
dieIfBuggyGit :: IO ()
dieIfBuggyGit :: IO ()
dieIfBuggyGit = do
GitVersion
version <- IO GitVersion
gitVersion
case ((GitVersion, Text)
-> [(GitVersion, Text)] -> [(GitVersion, Text)])
-> [(GitVersion, Text)]
-> [(GitVersion, Text)]
-> [(GitVersion, Text)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(GitVersion
ver, Text
err) [(GitVersion, Text)]
acc -> if GitVersion
version GitVersion -> GitVersion -> Bool
forall a. Ord a => a -> a -> Bool
< GitVersion
ver then (GitVersion
ver, Text
err) (GitVersion, Text) -> [(GitVersion, Text)] -> [(GitVersion, Text)]
forall a. a -> [a] -> [a]
: [(GitVersion, Text)]
acc else [(GitVersion, Text)]
acc) [] [(GitVersion, Text)]
validations of
[] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[(GitVersion, Text)]
errors ->
[Text] -> IO ()
forall a. [Text] -> IO a
die ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$
((GitVersion, Text) -> Text) -> [(GitVersion, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
(\(GitVersion
ver, Text
err) -> Text
"Prior to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
"git" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitVersion -> Text
showGitVersion GitVersion
ver Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err)
[(GitVersion, Text)]
errors
where
validations :: [(GitVersion, Text)]
validations :: [(GitVersion, Text)]
validations =
[ ( Int -> Int -> Int -> GitVersion
GitVersion Int
2 Int
29 Int
0,
Text -> Text
Text.bold Text
"git commit --patch"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was broken for new files added with "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
"git add --intent-to-add"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
),
( Int -> Int -> Int -> GitVersion
GitVersion Int
2 Int
30 Int
1,
Text -> Text
Text.bold Text
"git stash create"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" was broken for new files added with "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
"git add --intent-to-add"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
)
]
dieIfMergeInProgress :: IO ()
dieIfMergeInProgress :: IO ()
dieIfMergeInProgress =
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitMergeInProgress ([Text] -> IO ()
forall a. [Text] -> IO a
die [Text -> Text
Text.bold Text
"git merge" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in progress."])
dieIfNotInGitDir :: IO ()
dieIfNotInGitDir :: IO ()
dieIfNotInGitDir =
IO Text -> IO (Either ExitCode Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (Text -> IO Text
forall a. a -> IO a
evaluate Text
gitdir) IO (Either ExitCode Text)
-> (Either ExitCode Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (ExitCode
_ :: ExitCode) -> IO ()
forall a. IO a
exitFailure
Right Text
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
die :: [Text] -> IO a
die :: [Text] -> IO a
die [Text]
ss = do
Text -> IO ()
Text.putStr (Text -> Text
Text.red ([Text] -> Text
Text.unlines [Text]
ss))
IO a
forall a. IO a
exitFailure
mitBranch :: Text -> IO ()
mitBranch :: Text -> IO ()
mitBranch Text
branch = do
IO ()
dieIfNotInGitDir
Text -> IO (Maybe Text)
gitBranchWorktreeDir Text
branch IO (Maybe Text) -> (Maybe Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Text
Nothing ->
String -> IO Bool
doesDirectoryExist (Text -> String
Text.unpack Text
worktreeDir) IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> do
[Text] -> IO ()
git_ [Text
"worktree", Text
"add", Text
"--detach", Text
worktreeDir]
String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory (Text -> String
Text.unpack Text
worktreeDir) do
Text -> IO Bool
gitBranchExists Text
branch IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> do
Text -> IO ()
gitBranch Text
branch
Text -> IO ()
gitSwitch Text
branch
Text -> IO ()
gitFetch_ Text
"origin"
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Text -> Text -> IO Bool
gitRemoteBranchExists Text
"origin" Text
branch) do
let upstream :: Text
upstream = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
[Text] -> IO ()
git_ [Text
"reset", Text
"--hard", Text
upstream]
[Text] -> IO ()
git_ [Text
"branch", Text
"--set-upstream-to", Text
upstream]
Bool
True -> Text -> IO ()
gitSwitch Text
branch
Bool
True -> [Text] -> IO ()
forall a. [Text] -> IO a
die [Text
"Directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
worktreeDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already exists."]
Just Text
directory ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
directory Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
worktreeDir) do
[Text] -> IO ()
forall a. [Text] -> IO a
die [Text -> Text
Text.bold Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is already checked out in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold Text
directory Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."]
where
worktreeDir :: Text
worktreeDir :: Text
worktreeDir =
(Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
rootdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
mitCommit :: IO ()
mitCommit :: IO ()
mitCommit = do
IO ()
dieIfNotInGitDir
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitExistUntrackedFiles IO ()
dieIfBuggyGit
IO Bool
gitMergeInProgress IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False ->
IO DiffResult
gitDiff IO DiffResult -> (DiffResult -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
DiffResult
Differences -> IO ()
mitCommit_
DiffResult
NoDifferences -> IO ()
forall a. IO a
exitFailure
Bool
True -> IO ()
mitCommitMerge
mitCommit_ :: IO ()
mitCommit_ :: IO ()
mitCommit_ = do
Bool
fetched <- Text -> IO Bool
gitFetch Text
"origin"
Text
branch <- IO Text
gitCurrentBranch
let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
Text
head <- IO Text
gitHead
Maybe Text
maybeUpstreamHead <- Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
branch
Bool
existRemoteCommits <- IO Bool -> (Text -> IO Bool) -> Maybe Text -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (Text -> Text -> IO Bool
gitExistCommitsBetween Text
head) Maybe Text
maybeUpstreamHead
Bool
existLocalCommits <- IO Bool -> (Text -> IO Bool) -> Maybe Text -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (\Text
upstreamHead -> Text -> Text -> IO Bool
gitExistCommitsBetween Text
upstreamHead Text
"HEAD") Maybe Text
maybeUpstreamHead
MitState ()
state0 <- Text -> IO (MitState ())
readMitState Text
branch64
let wouldFork :: Bool
wouldFork = Bool
existRemoteCommits Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
existLocalCommits
let shouldWarnAboutFork :: IO Bool
shouldWarnAboutFork =
case Bool
wouldFork of
Bool
False -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Bool
True -> do
let theyRanMitCommitRecently :: IO Bool
theyRanMitCommitRecently =
case MitState ()
state0.ranCommitAt of
Maybe Integer
Nothing -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Just Integer
t0 -> do
Integer
t1 <- TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Integer) -> IO TimeSpec -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Realtime
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Integer
t1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
t0) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
10_000_000_000)
Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
theyRanMitCommitRecently
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
shouldWarnAboutFork do
Maybe Integer
ranCommitAt <- Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (TimeSpec -> Integer) -> TimeSpec -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Maybe Integer) -> IO TimeSpec -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Realtime
Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState ()
state0 {Maybe Integer
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt :: Maybe Integer
ranCommitAt}
[Text] -> IO ()
putLines
[ Text
"",
Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.yellow (Text -> Text
Text.italic Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not up to date."),
Text
"",
Text
" Run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold (Text -> Text
Text.blue Text
"mit sync") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" first, or run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold (Text -> Text
Text.blue Text
"mit commit")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" again to record a commit anyway.",
Text
""
]
IO ()
forall a. IO a
exitFailure
Text
stash <- IO Text
gitCreateStash
Bool
committed <- IO Bool
gitCommit
Seq GitCommitInfo
localCommits <- Maybe Text -> Text -> IO (Seq GitCommitInfo)
gitCommitsBetween Maybe Text
maybeUpstreamHead Text
"HEAD"
PushResult
pushResult <-
case (Seq GitCommitInfo
localCommits, Bool
existRemoteCommits, Bool
fetched) of
(Seq GitCommitInfo
Seq.Empty, Bool
_, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
NothingToPush)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Bool
True, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
ForkedHistory)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Bool
False, Bool
False) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
Offline)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Bool
False, Bool
True) -> Bool -> PushResult
PushAttempted (Bool -> PushResult) -> IO Bool -> IO PushResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Bool
gitPush Text
branch
let pushed :: Bool
pushed =
case PushResult
pushResult of
PushAttempted Bool
success -> Bool
success
PushNotAttempted PushNotAttemptedReason
_ -> Bool
False
Maybe Integer
ranCommitAt <-
case (Bool
wouldFork, Bool
committed) of
(Bool
True, Bool
False) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> (TimeSpec -> Integer) -> TimeSpec -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> Maybe Integer) -> IO TimeSpec -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Realtime
(Bool, Bool)
_ -> Maybe Integer -> IO (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
[Undo]
undos <-
case (Bool
pushed, Bool
committed, Seq GitCommitInfo
localCommits) of
(Bool
False, Bool
False, Seq GitCommitInfo
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
state0.undos
(Bool
False, Bool
True, Seq GitCommitInfo
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Undo
Reset Text
head, Text -> Undo
Apply Text
stash]
(Bool
True, Bool
True, GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
Seq.Empty) -> do
Text
head1 <- IO Text
gitHead
[Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Undo
Revert Text
head1, Text -> Undo
Apply Text
stash]
(Bool
True, Bool
_, Seq GitCommitInfo
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState {$sel:head:MitState :: ()
head = (), $sel:merging:MitState :: Maybe Text
merging = Maybe Text
forall a. Maybe a
Nothing, Maybe Integer
ranCommitAt :: Maybe Integer
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt, [Undo]
$sel:undos:MitState :: [Undo]
undos :: [Undo]
undos}
Summary -> IO ()
putSummary
Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
{ Text
$sel:branch:Summary :: Text
branch :: Text
branch,
$sel:canUndo:Summary :: Bool
canUndo = Bool -> Bool
not ([Undo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Undo]
undos) Bool -> Bool -> Bool
&& Bool
committed,
$sel:conflicts:Summary :: [GitConflict]
conflicts = [],
$sel:syncs:Summary :: [Sync]
syncs =
case Seq GitCommitInfo -> Maybe (Seq1 GitCommitInfo)
forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq Seq GitCommitInfo
localCommits of
Maybe (Seq1 GitCommitInfo)
Nothing -> []
Just Seq1 GitCommitInfo
commits ->
[ Sync :: Seq1 GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ Seq1 GitCommitInfo
$sel:commits:Sync :: Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
commits,
$sel:result:Sync :: SyncResult
result = PushResult -> SyncResult
pushResultToSyncResult PushResult
pushResult,
$sel:source:Sync :: Text
source = Text
branch,
$sel:target:Sync :: Text
target = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
}
]
}
mitCommitMerge :: IO ()
mitCommitMerge :: IO ()
mitCommitMerge = do
Text
branch <- IO Text
gitCurrentBranch
let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
Text
head <- IO Text
gitHead
MitState ()
state0 <- Text -> IO (MitState ())
readMitState Text
branch64
case MitState ()
state0.merging of
Maybe Text
Nothing -> [Text] -> IO ()
git_ [Text
"commit", Text
"--all", Text
"--no-edit"]
Just Text
merging ->
let message :: Text
message = [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Text
"⅄ ", if Text
merging Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
branch then Text
"" else Text
merging Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → ", Text
branch]
in [Text] -> IO ()
git_ [Text
"commit", Text
"--all", Text
"--message", Text
message]
case [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text
commit | Apply Text
commit <- MitState ()
state0.undos] of
Maybe Text
Nothing -> Maybe [Undo] -> IO ()
mitSyncWith ([Undo] -> Maybe [Undo]
forall a. a -> Maybe a
Just [Text -> Undo
Reset Text
head])
Just Text
stash ->
Text -> IO [GitConflict]
gitApplyStash Text
stash IO [GitConflict] -> ([GitConflict] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> Maybe [Undo] -> IO ()
mitSyncWith ([Undo] -> Maybe [Undo]
forall a. a -> Maybe a
Just [Text -> Undo
Reset Text
head, Text -> Undo
Apply Text
stash])
[GitConflict]
conflicts -> do
Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState ()
state0 {$sel:merging:MitState :: Maybe Text
merging = Maybe Text
forall a. Maybe a
Nothing, $sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing}
Summary -> IO ()
putSummary
Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
{ Text
branch :: Text
$sel:branch:Summary :: Text
branch,
$sel:canUndo:Summary :: Bool
canUndo = Bool -> Bool
not ([Undo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null MitState ()
state0.undos),
[GitConflict]
conflicts :: [GitConflict]
$sel:conflicts:Summary :: [GitConflict]
conflicts,
$sel:syncs:Summary :: [Sync]
syncs = []
}
data PushResult
= PushAttempted Bool
| PushNotAttempted PushNotAttemptedReason
data PushNotAttemptedReason
= ForkedHistory
| NothingToPush
| Offline
| UnseenCommits
pushResultToSyncResult :: PushResult -> SyncResult
pushResultToSyncResult :: PushResult -> SyncResult
pushResultToSyncResult = \case
PushAttempted Bool
False -> SyncResult
SyncResult'Failure
PushAttempted Bool
True -> SyncResult
SyncResult'Success
PushNotAttempted PushNotAttemptedReason
ForkedHistory -> SyncResult
SyncResult'Failure
PushNotAttempted PushNotAttemptedReason
NothingToPush -> SyncResult
SyncResult'Success
PushNotAttempted PushNotAttemptedReason
Offline -> SyncResult
SyncResult'Offline
PushNotAttempted PushNotAttemptedReason
UnseenCommits -> SyncResult
SyncResult'Pending
mitMerge :: Text -> IO ()
mitMerge :: Text -> IO ()
mitMerge Text
target = do
IO ()
dieIfNotInGitDir
IO ()
dieIfMergeInProgress
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitExistUntrackedFiles IO ()
dieIfBuggyGit
Text
branch <- IO Text
gitCurrentBranch
let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
Text
targetCommit <- do
Bool
_fetched <- Text -> IO Bool
gitFetch Text
"origin"
Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
target IO (Maybe Text) -> (IO (Maybe Text) -> IO Text) -> IO Text
forall a b. a -> (a -> b) -> b
& IO Text -> IO (Maybe Text) -> IO Text
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM ([Text] -> IO (Either ExitCode Text)
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"rev-parse", Text
target] IO (Either ExitCode Text)
-> (IO (Either ExitCode Text) -> IO Text) -> IO Text
forall a b. a -> (a -> b) -> b
& (ExitCode -> IO Text) -> IO (Either ExitCode Text) -> IO Text
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM \ExitCode
_ -> IO Text
forall a. IO a
exitFailure)
Maybe MergeStatus
maybeMergeStatus <- Text -> Text -> IO (Maybe MergeStatus)
mitMerge' (Text
"⅄ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch) Text
targetCommit
Text -> MitState () -> IO ()
writeMitState
Text
branch64
MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState
{ $sel:head:MitState :: ()
head = (),
$sel:merging:MitState :: Maybe Text
merging = do
MergeStatus
mergeStatus <- Maybe MergeStatus
maybeMergeStatus
case MergeStatus
mergeStatus.result of
MergeResult'MergeConflicts List1 GitConflict
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
target
MergeResult'StashConflicts [GitConflict]
_ -> Maybe Text
forall a. Maybe a
Nothing,
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing,
$sel:undos:MitState :: [Undo]
undos =
case Maybe MergeStatus
maybeMergeStatus of
Maybe MergeStatus
Nothing -> []
Just MergeStatus
mergeStatus -> MergeStatus
mergeStatus.undos
}
Summary -> IO ()
putSummary
Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
{ Text
branch :: Text
$sel:branch:Summary :: Text
branch,
$sel:canUndo:Summary :: Bool
canUndo = Maybe MergeStatus -> Bool
forall a. Maybe a -> Bool
isJust Maybe MergeStatus
maybeMergeStatus,
$sel:conflicts:Summary :: [GitConflict]
conflicts =
case Maybe MergeStatus
maybeMergeStatus of
Maybe MergeStatus
Nothing -> []
Just MergeStatus
mergeStatus ->
case MergeStatus
mergeStatus.result of
MergeResult'MergeConflicts List1 GitConflict
conflicts -> List1 GitConflict -> [GitConflict]
forall a. NonEmpty a -> [a]
List1.toList List1 GitConflict
conflicts
MergeResult'StashConflicts [GitConflict]
conflicts -> [GitConflict]
conflicts,
$sel:syncs:Summary :: [Sync]
syncs = do
MergeStatus
mergeStatus <- Maybe MergeStatus -> [MergeStatus]
forall a. Maybe a -> [a]
maybeToList Maybe MergeStatus
maybeMergeStatus
Sync -> [Sync]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Sync :: Seq1 GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ $sel:commits:Sync :: Seq1 GitCommitInfo
commits = MergeStatus
mergeStatus.commits,
$sel:result:Sync :: SyncResult
result =
case MergeStatus
mergeStatus.result of
MergeResult'MergeConflicts List1 GitConflict
_ -> SyncResult
SyncResult'Failure
MergeResult'StashConflicts [GitConflict]
_ -> SyncResult
SyncResult'Success,
$sel:source:Sync :: Text
source = Text
target,
$sel:target:Sync :: Text
target = Text
branch
}
}
data MergeStatus = MergeStatus
{ MergeStatus -> Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo,
MergeStatus -> MergeResult
result :: MergeResult,
MergeStatus -> [Undo]
undos :: [Undo]
}
data MergeResult
= MergeResult'MergeConflicts (List1 GitConflict)
| MergeResult'StashConflicts [GitConflict]
mitMerge' :: Text -> Text -> IO (Maybe MergeStatus)
mitMerge' :: Text -> Text -> IO (Maybe MergeStatus)
mitMerge' Text
message Text
target = do
Text
head <- IO Text
gitHead
(Seq GitCommitInfo -> Maybe (Seq1 GitCommitInfo)
forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq (Seq GitCommitInfo -> Maybe (Seq1 GitCommitInfo))
-> IO (Seq GitCommitInfo) -> IO (Maybe (Seq1 GitCommitInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> Text -> IO (Seq GitCommitInfo)
gitCommitsBetween (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
head) Text
target) IO (Maybe (Seq1 GitCommitInfo))
-> (Maybe (Seq1 GitCommitInfo) -> IO (Maybe MergeStatus))
-> IO (Maybe MergeStatus)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Seq1 GitCommitInfo)
Nothing -> Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MergeStatus
forall a. Maybe a
Nothing
Just Seq1 GitCommitInfo
commits -> do
Maybe Text
maybeStash <- IO (Maybe Text)
gitStash
let undos :: [Undo]
undos = Text -> Undo
Reset Text
head Undo -> [Undo] -> [Undo]
forall a. a -> [a] -> [a]
: Maybe Undo -> [Undo]
forall a. Maybe a -> [a]
maybeToList (Text -> Undo
Apply (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybeStash)
MergeResult
result <-
[Text] -> IO Bool
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"merge", Text
"--ff", Text
"--no-commit", Text
target] IO Bool -> (Bool -> IO MergeResult) -> IO MergeResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> do
[GitConflict]
conflicts <- IO [GitConflict]
gitConflicts
MergeResult -> IO MergeResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (List1 GitConflict -> MergeResult
MergeResult'MergeConflicts ([GitConflict] -> List1 GitConflict
forall a. [a] -> NonEmpty a
List1.fromList [GitConflict]
conflicts))
Bool
True -> do
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitMergeInProgress ([Text] -> IO ()
git_ [Text
"commit", Text
"--message", Text
message])
Maybe [GitConflict]
maybeConflicts <- Maybe Text
-> (Text -> IO [GitConflict]) -> IO (Maybe [GitConflict])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Text
maybeStash Text -> IO [GitConflict]
gitApplyStash
MergeResult -> IO MergeResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GitConflict] -> MergeResult
MergeResult'StashConflicts ([GitConflict] -> Maybe [GitConflict] -> [GitConflict]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [GitConflict]
maybeConflicts))
Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeStatus -> Maybe MergeStatus
forall a. a -> Maybe a
Just MergeStatus :: Seq1 GitCommitInfo -> MergeResult -> [Undo] -> MergeStatus
MergeStatus {Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
$sel:commits:MergeStatus :: Seq1 GitCommitInfo
commits, MergeResult
result :: MergeResult
$sel:result:MergeStatus :: MergeResult
result, [Undo]
undos :: [Undo]
$sel:undos:MergeStatus :: [Undo]
undos})
mitSync :: IO ()
mitSync :: IO ()
mitSync = do
IO ()
dieIfNotInGitDir
IO ()
dieIfMergeInProgress
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
gitExistUntrackedFiles IO ()
dieIfBuggyGit
Maybe [Undo] -> IO ()
mitSyncWith Maybe [Undo]
forall a. Maybe a
Nothing
mitSyncWith :: Maybe [Undo] -> IO ()
mitSyncWith :: Maybe [Undo] -> IO ()
mitSyncWith Maybe [Undo]
maybeUndos = do
Bool
fetched <- Text -> IO Bool
gitFetch Text
"origin"
Text
branch <- IO Text
gitCurrentBranch
let branch64 :: Text
branch64 = Text -> Text
Text.encodeBase64 Text
branch
Maybe Text
maybeUpstreamHead <- Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead Text
"origin" Text
branch
Maybe MergeStatus
maybeMergeStatus <-
case Maybe Text
maybeUpstreamHead of
Maybe Text
Nothing -> Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MergeStatus
forall a. Maybe a
Nothing
Just Text
upstreamHead -> Text -> Text -> IO (Maybe MergeStatus)
mitMerge' (Text
"⅄ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch) Text
upstreamHead
Seq GitCommitInfo
localCommits <- Maybe Text -> Text -> IO (Seq GitCommitInfo)
gitCommitsBetween Maybe Text
maybeUpstreamHead Text
"HEAD"
PushResult
pushResult <-
case (Seq GitCommitInfo
localCommits, (.result) (MergeStatus -> MergeResult)
-> Maybe MergeStatus -> Maybe MergeResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe MergeStatus
maybeMergeStatus, Bool
fetched) of
(Seq GitCommitInfo
Seq.Empty, Maybe MergeResult
_, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
NothingToPush)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Just (MergeResult'MergeConflicts List1 GitConflict
_), Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
ForkedHistory)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Just (MergeResult'StashConflicts [GitConflict]
_), Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
UnseenCommits)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Maybe MergeResult
Nothing, Bool
False) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
Offline)
(GitCommitInfo
_ Seq.:<| Seq GitCommitInfo
_, Maybe MergeResult
Nothing, Bool
True) -> Bool -> PushResult
PushAttempted (Bool -> PushResult) -> IO Bool -> IO PushResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Bool
gitPush Text
branch
let pushed :: Bool
pushed =
case PushResult
pushResult of
PushAttempted Bool
success -> Bool
success
PushNotAttempted PushNotAttemptedReason
_ -> Bool
False
let undos :: [Undo]
undos =
case Bool
pushed of
Bool
False -> [Undo] -> Maybe [Undo] -> [Undo]
forall a. a -> Maybe a -> a
fromMaybe ([Undo] -> (MergeStatus -> [Undo]) -> Maybe MergeStatus -> [Undo]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (.undos) Maybe MergeStatus
maybeMergeStatus) Maybe [Undo]
maybeUndos
Bool
True -> []
Text -> MitState () -> IO ()
writeMitState
Text
branch64
MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState
{ $sel:head:MitState :: ()
head = (),
$sel:merging:MitState :: Maybe Text
merging = do
MergeStatus
mergeStatus <- Maybe MergeStatus
maybeMergeStatus
case MergeStatus
mergeStatus.result of
MergeResult'MergeConflicts List1 GitConflict
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch
MergeResult'StashConflicts [GitConflict]
_ -> Maybe Text
forall a. Maybe a
Nothing,
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing,
[Undo]
undos :: [Undo]
$sel:undos:MitState :: [Undo]
undos
}
Summary -> IO ()
putSummary
Summary :: Text -> Bool -> [GitConflict] -> [Sync] -> Summary
Summary
{ Text
branch :: Text
$sel:branch:Summary :: Text
branch,
$sel:canUndo:Summary :: Bool
canUndo = Bool -> Bool
not ([Undo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Undo]
undos),
$sel:conflicts:Summary :: [GitConflict]
conflicts =
case Maybe MergeStatus
maybeMergeStatus of
Maybe MergeStatus
Nothing -> []
Just MergeStatus
mergeStatus ->
case MergeStatus
mergeStatus.result of
MergeResult'MergeConflicts List1 GitConflict
conflicts -> List1 GitConflict -> [GitConflict]
forall a. NonEmpty a -> [a]
List1.toList List1 GitConflict
conflicts
MergeResult'StashConflicts [GitConflict]
conflicts -> [GitConflict]
conflicts,
$sel:syncs:Summary :: [Sync]
syncs =
[Maybe Sync] -> [Sync]
forall a. [Maybe a] -> [a]
catMaybes
[ do
MergeStatus
mergeStatus <- Maybe MergeStatus
maybeMergeStatus
Sync -> Maybe Sync
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Sync :: Seq1 GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ $sel:commits:Sync :: Seq1 GitCommitInfo
commits = MergeStatus
mergeStatus.commits,
$sel:result:Sync :: SyncResult
result =
case MergeStatus
mergeStatus.result of
MergeResult'MergeConflicts List1 GitConflict
_ -> SyncResult
SyncResult'Failure
MergeResult'StashConflicts [GitConflict]
_ -> SyncResult
SyncResult'Success,
$sel:source:Sync :: Text
source = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch,
$sel:target:Sync :: Text
target = Text
branch
},
do
Seq1 GitCommitInfo
commits <- Seq GitCommitInfo -> Maybe (Seq1 GitCommitInfo)
forall a. Seq a -> Maybe (Seq1 a)
Seq1.fromSeq Seq GitCommitInfo
localCommits
Sync -> Maybe Sync
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Sync :: Seq1 GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo
$sel:commits:Sync :: Seq1 GitCommitInfo
commits,
$sel:result:Sync :: SyncResult
result = PushResult -> SyncResult
pushResultToSyncResult PushResult
pushResult,
$sel:source:Sync :: Text
source = Text
branch,
$sel:target:Sync :: Text
target = Text
"origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
}
]
}
mitUndo :: IO ()
mitUndo :: IO ()
mitUndo = do
IO ()
dieIfNotInGitDir
Text
branch64 <- Text -> Text
Text.encodeBase64 (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
gitCurrentBranch
MitState ()
state0 <- Text -> IO (MitState ())
readMitState Text
branch64
case [Undo] -> Maybe (NonEmpty Undo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty MitState ()
state0.undos of
Maybe (NonEmpty Undo)
Nothing -> IO ()
forall a. IO a
exitFailure
Just NonEmpty Undo
undos1 -> NonEmpty Undo -> IO ()
applyUndos NonEmpty Undo
undos1
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Undo] -> Bool
undosContainRevert MitState ()
state0.undos) IO ()
mitSync
where
undosContainRevert :: [Undo] -> Bool
undosContainRevert :: [Undo] -> Bool
undosContainRevert = \case
[] -> Bool
False
Revert Text
_ : [Undo]
_ -> Bool
True
Undo
_ : [Undo]
undos -> [Undo] -> Bool
undosContainRevert [Undo]
undos
data Summary = Summary
{ Summary -> Text
branch :: Text,
Summary -> Bool
canUndo :: Bool,
Summary -> [GitConflict]
conflicts :: [GitConflict],
Summary -> [Sync]
syncs :: [Sync]
}
data Sync = Sync
{ Sync -> Seq1 GitCommitInfo
commits :: Seq1 GitCommitInfo,
Sync -> SyncResult
result :: SyncResult,
Sync -> Text
source :: Text,
Sync -> Text
target :: Text
}
data SyncResult
= SyncResult'Failure
| SyncResult'Offline
| SyncResult'Pending
| SyncResult'Success
putSummary :: Summary -> IO ()
putSummary :: Summary -> IO ()
putSummary Summary
summary =
let output :: [Text]
output = (Sync -> [Text]) -> [Sync] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Sync -> [Text]
syncLines Summary
summary.syncs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
conflictsLines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
undoLines
in if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
output then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else [Text] -> IO ()
putLines (Text
"" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
output)
where
conflictsLines :: [Text]
conflictsLines :: [Text]
conflictsLines =
if [GitConflict] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Summary
summary.conflicts
then []
else
Text
" The following files have conflicts." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
(GitConflict -> Text) -> [GitConflict] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (GitConflict -> Text) -> GitConflict -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.red (Text -> Text) -> (GitConflict -> Text) -> GitConflict -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitConflict -> Text
showGitConflict) Summary
summary.conflicts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
""]
syncLines :: Sync -> [Text]
syncLines :: Sync -> [Text]
syncLines Sync
sync =
Text -> Text
colorize (Text -> Text
Text.italic (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sync
sync.source Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sync
sync.target)) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
(GitCommitInfo -> Text) -> [GitCommitInfo] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (GitCommitInfo -> Text) -> GitCommitInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitCommitInfo -> Text
prettyGitCommitInfo) (Seq GitCommitInfo -> [GitCommitInfo]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList @Seq Seq GitCommitInfo
commits')
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (if Bool
more then [Text
" ...", Text
""] else [Text
""])
where
colorize :: Text -> Text
colorize :: Text -> Text
colorize =
case Sync
sync.result of
SyncResult
SyncResult'Failure -> Text -> Text
Text.red
SyncResult
SyncResult'Offline -> Text -> Text
Text.brightBlack
SyncResult
SyncResult'Pending -> Text -> Text
Text.yellow
SyncResult
SyncResult'Success -> Text -> Text
Text.green
(Seq GitCommitInfo
commits', Bool
more) =
case Seq1 GitCommitInfo -> Int
forall a. Seq1 a -> Int
Seq1.length Sync
sync.commits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10 of
Bool
False -> (Seq1 GitCommitInfo -> Seq GitCommitInfo
forall a. Seq1 a -> Seq a
Seq1.toSeq Sync
sync.commits, Bool
False)
Bool
True -> (Int -> Seq1 GitCommitInfo -> Seq GitCommitInfo
forall a. Int -> Seq1 a -> Seq a
Seq1.dropEnd Int
1 Sync
sync.commits, Bool
True)
undoLines :: [Text]
undoLines :: [Text]
undoLines =
if Summary
summary.canUndo
then [Text
" Run " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Text.bold (Text -> Text
Text.blue Text
"mit undo") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to undo this change.", Text
""]
else []
data MitState a = MitState
{ MitState a -> a
head :: a,
MitState a -> Maybe Text
merging :: Maybe Text,
MitState a -> Maybe Integer
ranCommitAt :: Maybe Integer,
MitState a -> [Undo]
undos :: [Undo]
}
deriving stock (MitState a -> MitState a -> Bool
(MitState a -> MitState a -> Bool)
-> (MitState a -> MitState a -> Bool) -> Eq (MitState a)
forall a. Eq a => MitState a -> MitState a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MitState a -> MitState a -> Bool
$c/= :: forall a. Eq a => MitState a -> MitState a -> Bool
== :: MitState a -> MitState a -> Bool
$c== :: forall a. Eq a => MitState a -> MitState a -> Bool
Eq, Int -> MitState a -> ShowS
[MitState a] -> ShowS
MitState a -> String
(Int -> MitState a -> ShowS)
-> (MitState a -> String)
-> ([MitState a] -> ShowS)
-> Show (MitState a)
forall a. Show a => Int -> MitState a -> ShowS
forall a. Show a => [MitState a] -> ShowS
forall a. Show a => MitState a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MitState a] -> ShowS
$cshowList :: forall a. Show a => [MitState a] -> ShowS
show :: MitState a -> String
$cshow :: forall a. Show a => MitState a -> String
showsPrec :: Int -> MitState a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MitState a -> ShowS
Show)
emptyMitState :: MitState ()
emptyMitState :: MitState ()
emptyMitState =
MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState {$sel:head:MitState :: ()
head = (), $sel:merging:MitState :: Maybe Text
merging = Maybe Text
forall a. Maybe a
Nothing, $sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt = Maybe Integer
forall a. Maybe a
Nothing, $sel:undos:MitState :: [Undo]
undos = []}
deleteMitState :: Text -> IO ()
deleteMitState :: Text -> IO ()
deleteMitState Text
branch64 =
String -> IO ()
removeFile (Text -> String
mitfile Text
branch64) IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
parseMitState :: Text -> Maybe (MitState Text)
parseMitState :: Text -> Maybe (MitState Text)
parseMitState Text
contents = do
[Text
headLine, Text
mergingLine, Text
ranCommitAtLine, Text
undosLine] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Text -> [Text]
Text.lines Text
contents)
[Text
"head", Text
head] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (Text -> [Text]
Text.words Text
headLine)
Maybe Text
merging <-
case Text -> [Text]
Text.words Text
mergingLine of
[Text
"merging"] -> Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just Maybe Text
forall a. Maybe a
Nothing
[Text
"merging", Text
branch] -> Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch)
[Text]
_ -> Maybe (Maybe Text)
forall a. Maybe a
Nothing
Maybe Integer
ranCommitAt <-
case Text -> [Text]
Text.words Text
ranCommitAtLine of
[Text
"ran-commit-at"] -> Maybe Integer -> Maybe (Maybe Integer)
forall a. a -> Maybe a
Just Maybe Integer
forall a. Maybe a
Nothing
[Text
"ran-commit-at", Text -> Maybe Integer
text2int -> Just Integer
n] -> Maybe Integer -> Maybe (Maybe Integer)
forall a. a -> Maybe a
Just (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n)
[Text]
_ -> Maybe (Maybe Integer)
forall a. Maybe a
Nothing
[Undo]
undos <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"undos " Text
undosLine Maybe Text -> (Text -> Maybe [Undo]) -> Maybe [Undo]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe [Undo]
parseUndos
MitState Text -> Maybe (MitState Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState :: forall a. a -> Maybe Text -> Maybe Integer -> [Undo] -> MitState a
MitState {Text
head :: Text
$sel:head:MitState :: Text
head, Maybe Text
merging :: Maybe Text
$sel:merging:MitState :: Maybe Text
merging, Maybe Integer
ranCommitAt :: Maybe Integer
$sel:ranCommitAt:MitState :: Maybe Integer
ranCommitAt, [Undo]
undos :: [Undo]
$sel:undos:MitState :: [Undo]
undos}
readMitState :: Text -> IO (MitState ())
readMitState :: Text -> IO (MitState ())
readMitState Text
branch64 = do
Text
head <- IO Text
gitHead
IO Text -> IO (Either IOException Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO Text
Text.readFile (Text -> String
mitfile Text
branch64)) IO (Either IOException Text)
-> (Either IOException Text -> IO (MitState ()))
-> IO (MitState ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (IOException
_ :: IOException) -> MitState () -> IO (MitState ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
emptyMitState
Right Text
contents -> do
let maybeState :: Maybe (MitState Text)
maybeState = do
MitState Text
state <- Text -> Maybe (MitState Text)
parseMitState Text
contents
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
head Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== MitState Text
state.head)
MitState Text -> Maybe (MitState Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState Text
state
case Maybe (MitState Text)
maybeState of
Maybe (MitState Text)
Nothing -> do
Text -> IO ()
deleteMitState Text
branch64
MitState () -> IO (MitState ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
emptyMitState
Just MitState Text
state -> MitState () -> IO (MitState ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MitState Text
state {$sel:head:MitState :: ()
head = ()} :: MitState ())
writeMitState :: Text -> MitState () -> IO ()
writeMitState :: Text -> MitState () -> IO ()
writeMitState Text
branch64 MitState ()
state = do
Text
head <- IO Text
gitHead
let contents :: Text
contents :: Text
contents =
[Text] -> Text
Text.unlines
[ Text
"head " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
head,
Text
"merging " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
Text.empty MitState ()
state.merging,
Text
"ran-commit-at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Integer -> Text) -> Maybe Integer -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty Integer -> Text
int2text MitState ()
state.ranCommitAt,
Text
"undos " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Undo] -> Text
showUndos MitState ()
state.undos
]
String -> Text -> IO ()
Text.writeFile (Text -> String
mitfile Text
branch64) Text
contents IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mitfile :: Text -> FilePath
mitfile :: Text -> String
mitfile Text
branch64 =
Text -> String
Text.unpack (Text
gitdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/.mit-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch64)
data Undo
= Apply Text
| Reset Text
| Revert Text
deriving stock (Undo -> Undo -> Bool
(Undo -> Undo -> Bool) -> (Undo -> Undo -> Bool) -> Eq Undo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Undo -> Undo -> Bool
$c/= :: Undo -> Undo -> Bool
== :: Undo -> Undo -> Bool
$c== :: Undo -> Undo -> Bool
Eq, Int -> Undo -> ShowS
[Undo] -> ShowS
Undo -> String
(Int -> Undo -> ShowS)
-> (Undo -> String) -> ([Undo] -> ShowS) -> Show Undo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Undo] -> ShowS
$cshowList :: [Undo] -> ShowS
show :: Undo -> String
$cshow :: Undo -> String
showsPrec :: Int -> Undo -> ShowS
$cshowsPrec :: Int -> Undo -> ShowS
Show)
showUndos :: [Undo] -> Text
showUndos :: [Undo] -> Text
showUndos =
Text -> [Text] -> Text
Text.intercalate Text
" " ([Text] -> Text) -> ([Undo] -> [Text]) -> [Undo] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Undo -> Text) -> [Undo] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Undo -> Text
showUndo
where
showUndo :: Undo -> Text
showUndo :: Undo -> Text
showUndo = \case
Apply Text
commit -> Text
"apply/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit
Reset Text
commit -> Text
"reset/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit
Revert Text
commit -> Text
"revert/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit
parseUndos :: Text -> Maybe [Undo]
parseUndos :: Text -> Maybe [Undo]
parseUndos Text
t0 = do
(Text -> [Text]
Text.words (Text -> [Text])
-> ([Text] -> Maybe [Undo]) -> Text -> Maybe [Undo]
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Text -> Maybe Undo) -> [Text] -> Maybe [Undo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Maybe Undo
parseUndo) Text
t0
where
parseUndo :: Text -> Maybe Undo
parseUndo :: Text -> Maybe Undo
parseUndo Text
text =
[Maybe Undo] -> Maybe Undo
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
[ Text -> Undo
Apply (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
"apply/" Text
text,
Text -> Undo
Reset (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
"reset/" Text
text,
Text -> Undo
Revert (Text -> Undo) -> Maybe Text -> Maybe Undo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
Text.stripPrefix Text
"revert/" Text
text,
String -> Maybe Undo
forall a. HasCallStack => String -> a
error (Text -> String
forall a. Show a => a -> String
show Text
text)
]
applyUndos :: List1 Undo -> IO ()
applyUndos :: NonEmpty Undo -> IO ()
applyUndos =
(Undo -> IO ()) -> NonEmpty Undo -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ \case
Apply Text
commit -> IO [GitConflict] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> IO [GitConflict]
gitApplyStash Text
commit)
Reset Text
commit -> Text -> IO ()
gitResetHard Text
commit
Revert Text
commit -> Text -> IO ()
gitRevert Text
commit