{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Development.GitRev
( gitBranch
, gitCommitCount
, gitCommitDate
, gitDescribe
, gitDirty
, gitDirtyTracked
, gitHash
) where
import Control.Exception
import Control.Monad
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.Directory
import System.Exit
import System.FilePath
import System.Process
import Prelude ()
import Prelude.Compat
runGit :: [String] -> String -> IndexUsed -> Q String
runGit :: [String] -> String -> IndexUsed -> Q String
runGit [String]
args String
def IndexUsed
useIdx = do
let oops :: SomeException -> IO (ExitCode, String, String)
oops :: SomeException -> IO (ExitCode, String, String)
oops SomeException
_e = (ExitCode, String, String) -> IO (ExitCode, String, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1, String
def, String
"")
gitFound <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findExecutable String
"git"
if gitFound
then do
pwd <- runIO getDotGit
let hd = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
"HEAD"
index = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
"index"
packedRefs = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
"packed-refs"
hdExists <- runIO $ doesFileExist hd
when hdExists $ do
splitAt 5 `fmap` runIO (readFile hd) >>= \case
(String
"ref: ", String
relRef) -> do
let ref :: String
ref = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
relRef
refExists <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
ref
when refExists $ addDependentFile ref
(String, String)
_hash -> String -> Q ()
addDependentFile String
hd
indexExists <- runIO $ doesFileExist index
when (indexExists && useIdx == IdxUsed) $ addDependentFile index
packedExists <- runIO $ doesFileExist packedRefs
when packedExists $ addDependentFile packedRefs
runIO $ do
(code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
case code of
ExitCode
ExitSuccess -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
out)
ExitFailure Int
_ -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
def
else return def
getDotGit :: IO FilePath
getDotGit :: IO String
getDotGit = do
pwd <- IO String
getGitRoot
let dotGit = String
pwd String -> String -> String
</> String
".git"
oops = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
dotGit
isDir <- doesDirectoryExist dotGit
isFile <- doesFileExist dotGit
if | isDir -> return dotGit
| not isFile -> oops
| isFile ->
splitAt 8 `fmap` readFile dotGit >>= \case
(String
"gitdir: ", String
relDir) -> do
isRelDir <- String -> IO Bool
doesDirectoryExist String
relDir
if isRelDir
then return relDir
else oops
(String, String)
_ -> IO String
oops
getGitRoot :: IO FilePath
getGitRoot :: IO String
getGitRoot = do
pwd <- IO String
getCurrentDirectory
(code, out, _) <-
readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
case code of
ExitCode
ExitSuccess -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
out
ExitFailure Int
_ -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
pwd
data IndexUsed = IdxUsed
| IdxNotUsed
deriving (IndexUsed -> IndexUsed -> Bool
(IndexUsed -> IndexUsed -> Bool)
-> (IndexUsed -> IndexUsed -> Bool) -> Eq IndexUsed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IndexUsed -> IndexUsed -> Bool
== :: IndexUsed -> IndexUsed -> Bool
$c/= :: IndexUsed -> IndexUsed -> Bool
/= :: IndexUsed -> IndexUsed -> Bool
Eq)
gitHash :: ExpQ
gitHash :: ExpQ
gitHash =
String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"rev-parse", String
"HEAD"] String
"UNKNOWN" IndexUsed
IdxNotUsed
gitBranch :: ExpQ
gitBranch :: ExpQ
gitBranch =
String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"rev-parse", String
"--abbrev-ref", String
"HEAD"] String
"UNKNOWN" IndexUsed
IdxNotUsed
gitDescribe :: ExpQ
gitDescribe :: ExpQ
gitDescribe =
String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"describe", String
"--long", String
"--always"] String
"UNKNOWN" IndexUsed
IdxNotUsed
gitDirty :: ExpQ
gitDirty :: ExpQ
gitDirty = do
output <- [String] -> String -> IndexUsed -> Q String
runGit [String
"status", String
"--porcelain"] String
"" IndexUsed
IdxUsed
case output of
String
"" -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseName
String
_ -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueName
gitDirtyTracked :: ExpQ
gitDirtyTracked :: ExpQ
gitDirtyTracked = do
output <- [String] -> String -> IndexUsed -> Q String
runGit [String
"status", String
"--porcelain",String
"--untracked-files=no"] String
"" IndexUsed
IdxUsed
case output of
String
"" -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
falseName
String
_ -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueName
gitCommitCount :: ExpQ
gitCommitCount :: ExpQ
gitCommitCount =
String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"rev-list", String
"HEAD", String
"--count"] String
"UNKNOWN" IndexUsed
IdxNotUsed
gitCommitDate :: ExpQ
gitCommitDate :: ExpQ
gitCommitDate =
String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"log", String
"HEAD", String
"-1", String
"--format=%cd"] String
"UNKNOWN" IndexUsed
IdxNotUsed