{-# 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

-- Check whether the working directory is clean
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

-- | Ensure that git repo is clean
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 2.3+
      , ("GIT_ASKPASS", "echo") -- pre git 2.3 to just use empty password
      , ("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']

-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
-- ref: refs/heads/master	HEAD
-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5	refs/heads/master
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)