{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}
module Mit where
import qualified Data.List.NonEmpty as List1
import qualified Data.Text as Text
import qualified Data.Text.ANSI as Text
import qualified Data.Text.Encoding.Base64 as Text
import qualified Data.Text.IO as Text
import Mit.Git
import Mit.Prelude
import qualified System.Clock as Clock
import System.Directory (doesDirectoryExist, removeFile, withCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (ExitCode (..), exitFailure)
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
"clone", Text -> Maybe (Text, Text)
parseGitRepo (Text -> Maybe (Text, Text))
-> (String -> Text) -> String -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack -> Just (Text
url, Text
name)] -> Text -> Text -> IO ()
mitClone Text
url Text
name
[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
gitdir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
mitClone :: Text -> Text -> IO ()
mitClone :: Text -> Text -> IO ()
mitClone Text
url Text
name =
[Text] -> IO ()
forall a. ProcessOutput a => [Text] -> IO a
git [Text
"clone", Text
url, Text
"--separate-git-dir", Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/.git", Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/master"]
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 DiffResult
gitDiff IO DiffResult -> (DiffResult -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
DiffResult
Differences ->
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 ()
mitCommit_
Bool
True -> IO ()
mitCommitMerge
DiffResult
NoDifferences -> IO ()
forall a. IO a
exitFailure
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.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
[GitCommitInfo]
localCommits <- Maybe Text -> Text -> IO [GitCommitInfo]
gitCommitsBetween Maybe Text
maybeUpstreamHead Text
"HEAD"
PushResult
pushResult <-
case ([GitCommitInfo]
localCommits, Bool
existRemoteCommits, Bool
fetched) of
([], Bool
_, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
NothingToPush)
(GitCommitInfo
_ : [GitCommitInfo]
_, Bool
True, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
ForkedHistory)
(GitCommitInfo
_ : [GitCommitInfo]
_, Bool
False, Bool
False) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
Offline)
(GitCommitInfo
_ : [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, [GitCommitInfo]
localCommits) of
(Bool
False, Bool
False, [GitCommitInfo]
_) -> [Undo] -> IO [Undo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure MitState ()
state0.undos
(Bool
False, Bool
True, [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
_]) -> 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
_, [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 [GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitCommitInfo]
localCommits of
Maybe (NonEmpty GitCommitInfo)
Nothing -> []
Just NonEmpty GitCommitInfo
commits ->
[ Sync :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ NonEmpty GitCommitInfo
$sel:commits:Sync :: NonEmpty GitCommitInfo
commits :: NonEmpty 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 :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ $sel:commits:Sync :: NonEmpty 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 -> NonEmpty GitCommitInfo
commits :: List1 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
([GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty ([GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo))
-> IO [GitCommitInfo] -> IO (Maybe (NonEmpty GitCommitInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> Text -> IO [GitCommitInfo]
gitCommitsBetween (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
head) Text
target) IO (Maybe (NonEmpty GitCommitInfo))
-> (Maybe (NonEmpty GitCommitInfo) -> IO (Maybe MergeStatus))
-> IO (Maybe MergeStatus)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (NonEmpty GitCommitInfo)
Nothing -> Maybe MergeStatus -> IO (Maybe MergeStatus)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MergeStatus
forall a. Maybe a
Nothing
Just NonEmpty 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 :: NonEmpty GitCommitInfo -> MergeResult -> [Undo] -> MergeStatus
MergeStatus {NonEmpty GitCommitInfo
commits :: NonEmpty GitCommitInfo
$sel:commits:MergeStatus :: NonEmpty 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
[GitCommitInfo]
localCommits <- Maybe Text -> Text -> IO [GitCommitInfo]
gitCommitsBetween Maybe Text
maybeUpstreamHead Text
"HEAD"
PushResult
pushResult <-
case ([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
([], Maybe MergeResult
_, Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
NothingToPush)
(GitCommitInfo
_ : [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
_ : [GitCommitInfo]
_, Just (MergeResult'StashConflicts [GitConflict]
_), Bool
_) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
UnseenCommits)
(GitCommitInfo
_ : [GitCommitInfo]
_, Maybe MergeResult
Nothing, Bool
False) -> PushResult -> IO PushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PushNotAttemptedReason -> PushResult
PushNotAttempted PushNotAttemptedReason
Offline)
(GitCommitInfo
_ : [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 :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ $sel:commits:Sync :: NonEmpty 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
NonEmpty GitCommitInfo
commits <- [GitCommitInfo] -> Maybe (NonEmpty GitCommitInfo)
forall a. [a] -> Maybe (NonEmpty a)
List1.nonEmpty [GitCommitInfo]
localCommits
Sync -> Maybe Sync
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Sync :: NonEmpty GitCommitInfo -> SyncResult -> Text -> Text -> Sync
Sync
{ NonEmpty GitCommitInfo
commits :: NonEmpty GitCommitInfo
$sel:commits:Sync :: NonEmpty 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 -> NonEmpty GitCommitInfo
commits :: List1 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) (NonEmpty GitCommitInfo -> [GitCommitInfo]
forall a. NonEmpty a -> [a]
List1.toList Sync
sync.commits)
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [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
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