{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module Bindings.Cli.Git
( CommitId
, gitProc
, ensureCleanGitRepo
, readGitProcess
, isolateGitProc
, gitProcNoRepo
, gitLsRemote
, gitLookupDefaultBranch
, gitLookupCommitForRef
, GitRef (..)
) where
import Control.Applicative hiding (many)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Except
import Control.Monad.Fail
import Control.Monad.Log
import Data.Bool (bool)
import Data.Bifunctor
import Data.Char
import Data.Either
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
import Data.Semigroup ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import System.Exit (ExitCode)
import qualified Text.Megaparsec.Char.Lexer as ML
import Text.Megaparsec as MP
import Text.Megaparsec.Char as MP
import Cli.Extras
checkGitCleanStatus
:: ( MonadIO m
, MonadLog Output m
, MonadError e m
, AsProcessFailure e
, MonadFail m
)
=> FilePath
-> Bool
-> m Bool
checkGitCleanStatus :: FilePath -> Bool -> m Bool
checkGitCleanStatus repo :: FilePath
repo withIgnored :: Bool
withIgnored = do
let
runGit :: [FilePath] -> m Text
runGit = Severity -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadFail m) =>
Severity -> ProcessSpec -> m Text
readProcessAndLogStderr Severity
Debug (ProcessSpec -> m Text)
-> ([FilePath] -> ProcessSpec) -> [FilePath] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessSpec
gitProc FilePath
repo
gitStatus :: m Text
gitStatus = [FilePath] -> m Text
runGit ([FilePath] -> m Text) -> [FilePath] -> m Text
forall a b. (a -> b) -> a -> b
$ ["status", "--porcelain"] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall a. a -> a -> Bool -> a
bool [] ["--ignored"] Bool
withIgnored
gitDiff :: m Text
gitDiff = [FilePath] -> m Text
runGit ["diff"]
Text -> Bool
T.null (Text -> Bool) -> m Text -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text -> Text) -> m Text -> m Text -> m Text
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) m Text
gitStatus m Text
gitDiff
ensureCleanGitRepo
:: ( MonadIO m
, MonadLog Output m
, MonadError e m
, AsProcessFailure e
, MonadFail m
, HasCliConfig m
, MonadMask m
, AsUnstructuredError e
)
=> FilePath
-> Bool
-> Text
-> m ()
ensureCleanGitRepo :: FilePath -> Bool -> Text -> m ()
ensureCleanGitRepo path :: FilePath
path withIgnored :: Bool
withIgnored s :: Text
s =
Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig m) =>
Text -> m a -> m a
withSpinnerNoTrail ("Ensuring clean git repo at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
path) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Bool -> m Bool
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m) =>
FilePath -> Bool -> m Bool
checkGitCleanStatus FilePath
path Bool
withIgnored m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
False -> do
Text
statusDebug <- FilePath -> [FilePath] -> m Text
forall (m :: * -> *) e.
(MonadIO m, MonadLog Output m, MonadError e m, AsProcessFailure e,
MonadFail m) =>
FilePath -> [FilePath] -> m Text
readGitProcess FilePath
path ([FilePath] -> m Text) -> [FilePath] -> m Text
forall a b. (a -> b) -> a -> b
$ ["status"] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> [FilePath] -> Bool -> [FilePath]
forall a. a -> a -> Bool -> a
bool [] ["--ignored"] Bool
withIgnored
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Warning "Working copy is unsaved; git status:"
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Notice Text
statusDebug
Text -> m ()
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith Text
s
True -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
gitProcNoRepo :: [String] -> ProcessSpec
gitProcNoRepo :: [FilePath] -> ProcessSpec
gitProcNoRepo args :: [FilePath]
args = (Map FilePath FilePath -> Map FilePath FilePath)
-> ProcessSpec -> ProcessSpec
setEnvOverride (FilePath -> FilePath -> Map FilePath FilePath
forall k a. k -> a -> Map k a
M.singleton "GIT_TERMINAL_PROMPT" "0" Map FilePath FilePath
-> Map FilePath FilePath -> Map FilePath FilePath
forall a. Semigroup a => a -> a -> a
<>) (ProcessSpec -> ProcessSpec) -> ProcessSpec -> ProcessSpec
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessSpec
proc "git" [FilePath]
args
gitProc :: FilePath -> [String] -> ProcessSpec
gitProc :: FilePath -> [FilePath] -> ProcessSpec
gitProc repo :: FilePath
repo = [FilePath] -> ProcessSpec
gitProcNoRepo ([FilePath] -> ProcessSpec)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> ProcessSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
runGitInDir
where
runGitInDir :: [FilePath] -> [FilePath]
runGitInDir args' :: [FilePath]
args' = case (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [FilePath]
args' of
args :: [FilePath]
args@("clone":_) -> [FilePath]
args [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath
repo]
args :: [FilePath]
args -> ["-C", FilePath
repo] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
args
isolateGitProc :: ProcessSpec -> ProcessSpec
isolateGitProc :: ProcessSpec -> ProcessSpec
isolateGitProc = (Map FilePath FilePath -> Map FilePath FilePath)
-> ProcessSpec -> ProcessSpec
setEnvOverride (Map FilePath FilePath
overrides Map FilePath FilePath
-> Map FilePath FilePath -> Map FilePath FilePath
forall a. Semigroup a => a -> a -> a
<>)
where
overrides :: Map FilePath FilePath
overrides = [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ ("HOME", "/dev/null")
, ("GIT_CONFIG_NOSYSTEM", "1")
, ("GIT_TERMINAL_PROMPT", "0")
, ("GIT_ASKPASS", "echo")
, ("GIT_SSH_COMMAND", "ssh -o PreferredAuthentications password -o PubkeyAuthentication no -o GSSAPIAuthentication no")
]
readGitProcess
:: ( MonadIO m
, MonadLog Output m
, MonadError e m
, AsProcessFailure e
, MonadFail m
)
=> FilePath -> [String] -> m Text
readGitProcess :: FilePath -> [FilePath] -> m Text
readGitProcess repo :: FilePath
repo = (Severity, Severity) -> ProcessSpec -> m Text
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e,
MonadFail m) =>
(Severity, Severity) -> ProcessSpec -> m Text
readProcessAndLogOutput (Severity
Debug, Severity
Notice) (ProcessSpec -> m Text)
-> ([FilePath] -> ProcessSpec) -> [FilePath] -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessSpec
gitProc FilePath
repo
gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
gitLookupDefaultBranch (refs :: Map GitRef GitRef
refs, _) = do
GitRef
ref <- case GitRef -> Map GitRef GitRef -> Maybe GitRef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GitRef
GitRef_Head Map GitRef GitRef
refs of
Just ref :: GitRef
ref -> GitRef -> Either Text GitRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure GitRef
ref
Nothing -> Text -> Either Text GitRef
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
"No symref entry for HEAD. \
\ Is your git version at least 1.8.5? \
\ Otherwise `git ls-remote --symref` will not work."
case GitRef
ref of
GitRef_Branch b :: Text
b -> Text -> Either Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
b
_ -> Text -> Either Text Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$
"Default ref " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitRef -> Text
showGitRef GitRef
ref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is not a branch!"
gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text Text
gitLookupCommitForRef (_, commits :: Map GitRef Text
commits) ref :: GitRef
ref = case GitRef -> Map GitRef Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup GitRef
ref Map GitRef Text
commits of
Just a :: Text
a -> Text -> Either Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
a
Nothing -> Text -> Either Text Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ "Did not find commit for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GitRef -> Text
showGitRef GitRef
ref
gitLsRemote
:: ( MonadIO m
, MonadLog Output m
, MonadError e m
, AsProcessFailure e
, MonadFail m
, AsUnstructuredError e
)
=> String
-> Maybe GitRef
-> Maybe String
-> m (ExitCode, GitLsRemoteMaps)
gitLsRemote :: FilePath
-> Maybe GitRef -> Maybe FilePath -> m (ExitCode, GitLsRemoteMaps)
gitLsRemote repository :: FilePath
repository mRef :: Maybe GitRef
mRef mBranch :: Maybe FilePath
mBranch = do
(exitCode :: ExitCode
exitCode, out :: FilePath
out, _err :: FilePath
_err) <- case Maybe FilePath
mBranch of
Nothing -> ProcessSpec -> m (ExitCode, FilePath, FilePath)
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e) =>
ProcessSpec -> m (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode (ProcessSpec -> m (ExitCode, FilePath, FilePath))
-> ProcessSpec -> m (ExitCode, FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ProcessSpec
gitProcNoRepo ([FilePath] -> ProcessSpec) -> [FilePath] -> ProcessSpec
forall a b. (a -> b) -> a -> b
$
["ls-remote", "--exit-code", "--symref", FilePath
repository]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList (Text -> FilePath
T.unpack (Text -> FilePath) -> (GitRef -> Text) -> GitRef -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitRef -> Text
showGitRef (GitRef -> FilePath) -> Maybe GitRef -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GitRef
mRef)
Just branchName :: FilePath
branchName -> ProcessSpec -> m (ExitCode, FilePath, FilePath)
forall (m :: * -> *) e.
(MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e) =>
ProcessSpec -> m (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode (ProcessSpec -> m (ExitCode, FilePath, FilePath))
-> ProcessSpec -> m (ExitCode, FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ProcessSpec
gitProcNoRepo
["ls-remote", "--exit-code", FilePath
repository, FilePath
branchName]
let t :: Text
t = FilePath -> Text
T.pack FilePath
out
GitLsRemoteMaps
maps <- case Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
-> FilePath
-> Text
-> Either
(ParseErrorBundle Text Void)
[Either (GitRef, GitRef) (GitRef, Text)]
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
MP.runParser Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
parseLsRemote "" Text
t of
Left err :: ParseErrorBundle Text Void
err -> Text -> m GitLsRemoteMaps
forall e (m :: * -> *) a.
(CliThrow e m, AsUnstructuredError e) =>
Text -> m a
failWith (Text -> m GitLsRemoteMaps) -> Text -> m GitLsRemoteMaps
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> FilePath
forall s e.
(Stream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
MP.errorBundlePretty ParseErrorBundle Text Void
err
Right table :: [Either (GitRef, GitRef) (GitRef, Text)]
table -> GitLsRemoteMaps -> m GitLsRemoteMaps
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitLsRemoteMaps -> m GitLsRemoteMaps)
-> GitLsRemoteMaps -> m GitLsRemoteMaps
forall a b. (a -> b) -> a -> b
$ ([(GitRef, GitRef)] -> Map GitRef GitRef)
-> ([(GitRef, Text)] -> Map GitRef Text)
-> ([(GitRef, GitRef)], [(GitRef, Text)])
-> GitLsRemoteMaps
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [(GitRef, GitRef)] -> Map GitRef GitRef
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(GitRef, Text)] -> Map GitRef Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (([(GitRef, GitRef)], [(GitRef, Text)]) -> GitLsRemoteMaps)
-> ([(GitRef, GitRef)], [(GitRef, Text)]) -> GitLsRemoteMaps
forall a b. (a -> b) -> a -> b
$ [Either (GitRef, GitRef) (GitRef, Text)]
-> ([(GitRef, GitRef)], [(GitRef, Text)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (GitRef, GitRef) (GitRef, Text)]
table
Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "git ls-remote maps: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (GitLsRemoteMaps -> FilePath
forall a. Show a => a -> FilePath
show GitLsRemoteMaps
maps)
(ExitCode, GitLsRemoteMaps) -> m (ExitCode, GitLsRemoteMaps)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode
exitCode, GitLsRemoteMaps
maps)
lexeme :: Parsec Void Text a -> Parsec Void Text a
lexeme :: Parsec Void Text a -> Parsec Void Text a
lexeme = ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
ML.lexeme (ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a)
-> ParsecT Void Text Identity ()
-> Parsec Void Text a
-> Parsec Void Text a
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "within-line white space") ((Token Text -> Bool) -> ParsecT Void Text Identity Text)
-> (Token Text -> Bool) -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
(Char -> FilePath -> Bool) -> FilePath -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [' ', '\t']
parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, CommitId)]
parseLsRemote :: Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
parseLsRemote =
ParsecT Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((((GitRef, GitRef) -> Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT
Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GitRef, GitRef) -> Either (GitRef, GitRef) (GitRef, Text)
forall a b. a -> Either a b
Left (ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity (GitRef, GitRef)
parseRef) ParsecT Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT
Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT
Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((GitRef, Text) -> Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT Void Text Identity (GitRef, Text)
-> ParsecT
Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GitRef, Text) -> Either (GitRef, GitRef) (GitRef, Text)
forall a b. b -> Either a b
Right ParsecT Void Text Identity (GitRef, Text)
parseCommit) ParsecT Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
-> ParsecT Void Text Identity Text
-> ParsecT
Void Text Identity (Either (GitRef, GitRef) (GitRef, Text))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Text
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
MP.eol) Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
-> ParsecT Void Text Identity ()
-> Parsec Void Text [Either (GitRef, GitRef) (GitRef, Text)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof
where
parseRef :: Parsec Void Text (GitRef, GitRef)
parseRef :: ParsecT Void Text Identity (GitRef, GitRef)
parseRef = FilePath
-> ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
FilePath -> m a -> m a
MP.label "ref and symbolic ref" (ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef))
-> ParsecT Void Text Identity (GitRef, GitRef)
-> ParsecT Void Text Identity (GitRef, GitRef)
forall a b. (a -> b) -> a -> b
$ do
Text
_ <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme "ref:"
Text
ref <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "ref") ((Token Text -> Bool) -> ParsecT Void Text Identity Text)
-> (Token Text -> Bool) -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
Text
symbolicRef <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "symbolic ref") ((Token Text -> Bool) -> ParsecT Void Text Identity Text)
-> (Token Text -> Bool) -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
(GitRef, GitRef) -> ParsecT Void Text Identity (GitRef, GitRef)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> GitRef
toGitRef Text
symbolicRef, Text -> GitRef
toGitRef Text
ref)
parseCommit :: Parsec Void Text (GitRef, CommitId)
parseCommit :: ParsecT Void Text Identity (GitRef, Text)
parseCommit = FilePath
-> ParsecT Void Text Identity (GitRef, Text)
-> ParsecT Void Text Identity (GitRef, Text)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
FilePath -> m a -> m a
MP.label "commit and ref" (ParsecT Void Text Identity (GitRef, Text)
-> ParsecT Void Text Identity (GitRef, Text))
-> ParsecT Void Text Identity (GitRef, Text)
-> ParsecT Void Text Identity (GitRef, Text)
forall a b. (a -> b) -> a -> b
$ do
Text
commitId <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "commit id") ((Token Text -> Bool) -> ParsecT Void Text Identity Text)
-> (Token Text -> Bool) -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
Text
ref <- ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
MP.takeWhileP (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "ref") ((Token Text -> Bool) -> ParsecT Void Text Identity Text)
-> (Token Text -> Bool) -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
(GitRef, Text) -> ParsecT Void Text Identity (GitRef, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> GitRef
toGitRef Text
ref, Text
commitId)
data GitRef
= GitRef_Head
| GitRef_Branch Text
| GitRef_Tag Text
| GitRef_Other Text
deriving (Int -> GitRef -> ShowS
[GitRef] -> ShowS
GitRef -> FilePath
(Int -> GitRef -> ShowS)
-> (GitRef -> FilePath) -> ([GitRef] -> ShowS) -> Show GitRef
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [GitRef] -> ShowS
$cshowList :: [GitRef] -> ShowS
show :: GitRef -> FilePath
$cshow :: GitRef -> FilePath
showsPrec :: Int -> GitRef -> ShowS
$cshowsPrec :: Int -> GitRef -> ShowS
Show, GitRef -> GitRef -> Bool
(GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool) -> Eq GitRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitRef -> GitRef -> Bool
$c/= :: GitRef -> GitRef -> Bool
== :: GitRef -> GitRef -> Bool
$c== :: GitRef -> GitRef -> Bool
Eq, Eq GitRef
Eq GitRef =>
(GitRef -> GitRef -> Ordering)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> Bool)
-> (GitRef -> GitRef -> GitRef)
-> (GitRef -> GitRef -> GitRef)
-> Ord GitRef
GitRef -> GitRef -> Bool
GitRef -> GitRef -> Ordering
GitRef -> GitRef -> GitRef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GitRef -> GitRef -> GitRef
$cmin :: GitRef -> GitRef -> GitRef
max :: GitRef -> GitRef -> GitRef
$cmax :: GitRef -> GitRef -> GitRef
>= :: GitRef -> GitRef -> Bool
$c>= :: GitRef -> GitRef -> Bool
> :: GitRef -> GitRef -> Bool
$c> :: GitRef -> GitRef -> Bool
<= :: GitRef -> GitRef -> Bool
$c<= :: GitRef -> GitRef -> Bool
< :: GitRef -> GitRef -> Bool
$c< :: GitRef -> GitRef -> Bool
compare :: GitRef -> GitRef -> Ordering
$ccompare :: GitRef -> GitRef -> Ordering
$cp1Ord :: Eq GitRef
Ord)
showGitRef :: GitRef -> Text
showGitRef :: GitRef -> Text
showGitRef = \case
GitRef_Head -> "HEAD"
GitRef_Branch x :: Text
x -> "refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
GitRef_Tag x :: Text
x -> "refs/tags/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
GitRef_Other x :: Text
x -> Text
x
toGitRef :: Text -> GitRef
toGitRef :: Text -> GitRef
toGitRef = \case
"HEAD" -> GitRef
GitRef_Head
r :: Text
r -> if
| Just s :: Text
s <- "refs/heads/" Text -> Text -> Maybe Text
`T.stripPrefix` Text
r -> Text -> GitRef
GitRef_Branch Text
s
| Just s :: Text
s <- "refs/tags/" Text -> Text -> Maybe Text
`T.stripPrefix` Text
r -> Text -> GitRef
GitRef_Tag Text
s
| Bool
otherwise -> Text -> GitRef
GitRef_Other Text
r
type CommitId = Text
type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)