{-# 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 args :: [String]
args def :: String
def useIdx :: IndexUsed
useIdx = do
let oops :: SomeException -> IO (ExitCode, String, String)
oops :: SomeException -> IO (ExitCode, String, String)
oops _e :: SomeException
_e = (ExitCode, String, String) -> IO (ExitCode, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure 1, String
def, "")
Bool
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 "git"
if Bool
gitFound
then do
String
pwd <- IO String -> Q String
forall a. IO a -> Q a
runIO IO String
getDotGit
let hd :: String
hd = String
pwd String -> String -> String
</> ".git" String -> String -> String
</> "HEAD"
index :: String
index = String
pwd String -> String -> String
</> ".git" String -> String -> String
</> "index"
packedRefs :: String
packedRefs = String
pwd String -> String -> String
</> ".git" String -> String -> String
</> "packed-refs"
Bool
hdExists <- 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
hd
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hdExists (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 5 (String -> (String, String)) -> Q String -> Q (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO String -> Q String
forall a. IO a -> Q a
runIO (String -> IO String
readFile String
hd) Q (String, String) -> ((String, String) -> Q ()) -> Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
("ref: ", relRef :: String
relRef) -> do
let ref :: String
ref = String
pwd String -> String -> String
</> ".git" String -> String -> String
</> String
relRef
Bool
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
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
refExists (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
addDependentFile String
ref
_hash :: (String, String)
_hash -> String -> Q ()
addDependentFile String
hd
Bool
indexExists <- 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
index
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
indexExists Bool -> Bool -> Bool
&& IndexUsed
useIdx IndexUsed -> IndexUsed -> Bool
forall a. Eq a => a -> a -> Bool
== IndexUsed
IdxUsed) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
addDependentFile String
index
Bool
packedExists <- 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
packedRefs
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
packedExists (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
addDependentFile String
packedRefs
IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ do
(code :: ExitCode
code, out :: String
out, _err :: String
_err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode "git" [String]
args "" IO (ExitCode, String, String)
-> (SomeException -> IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (ExitCode, String, String)
oops
case ExitCode
code of
ExitSuccess -> String -> IO String
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
/= '\n') String
out)
ExitFailure _ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
def
else String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return String
def
getDotGit :: IO FilePath
getDotGit :: IO String
getDotGit = do
String
pwd <- IO String
getGitRoot
let dotGit :: String
dotGit = String
pwd String -> String -> String
</> ".git"
oops :: IO String
oops = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dotGit
Bool
isDir <- String -> IO Bool
doesDirectoryExist String
dotGit
Bool
isFile <- String -> IO Bool
doesFileExist String
dotGit
if | Bool
isDir -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dotGit
| Bool -> Bool
not Bool
isFile -> IO String
oops
| Bool
isFile ->
Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 8 (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO String
readFile String
dotGit IO (String, String) -> ((String, String) -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
("gitdir: ", relDir :: String
relDir) -> do
Bool
isRelDir <- String -> IO Bool
doesDirectoryExist String
relDir
if Bool
isRelDir
then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
relDir
else IO String
oops
_ -> IO String
oops
getGitRoot :: IO FilePath
getGitRoot :: IO String
getGitRoot = do
String
pwd <- IO String
getCurrentDirectory
(code :: ExitCode
code, out :: String
out, _) <-
String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
case ExitCode
code of
ExitSuccess -> String -> IO String
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
/= '\n') String
out
ExitFailure _ -> String -> IO String
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
/= :: IndexUsed -> IndexUsed -> Bool
$c/= :: IndexUsed -> IndexUsed -> Bool
== :: IndexUsed -> IndexUsed -> Bool
$c== :: IndexUsed -> IndexUsed -> Bool
Eq)
gitHash :: ExpQ
gitHash :: ExpQ
gitHash =
String -> ExpQ
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 ["rev-parse", "HEAD"] "UNKNOWN" IndexUsed
IdxNotUsed
gitBranch :: ExpQ
gitBranch :: ExpQ
gitBranch =
String -> ExpQ
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 ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IndexUsed
IdxNotUsed
gitDescribe :: ExpQ
gitDescribe :: ExpQ
gitDescribe =
String -> ExpQ
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 ["describe", "--long", "--always"] "UNKNOWN" IndexUsed
IdxNotUsed
gitDirty :: ExpQ
gitDirty :: ExpQ
gitDirty = do
String
output <- [String] -> String -> IndexUsed -> Q String
runGit ["status", "--porcelain"] "" IndexUsed
IdxUsed
case String
output of
"" -> Name -> ExpQ
conE Name
falseName
_ -> Name -> ExpQ
conE Name
trueName
gitDirtyTracked :: ExpQ
gitDirtyTracked :: ExpQ
gitDirtyTracked = do
String
output <- [String] -> String -> IndexUsed -> Q String
runGit ["status", "--porcelain","--untracked-files=no"] "" IndexUsed
IdxUsed
case String
output of
"" -> Name -> ExpQ
conE Name
falseName
_ -> Name -> ExpQ
conE Name
trueName
gitCommitCount :: ExpQ
gitCommitCount :: ExpQ
gitCommitCount =
String -> ExpQ
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 ["rev-list", "HEAD", "--count"] "UNKNOWN" IndexUsed
IdxNotUsed
gitCommitDate :: ExpQ
gitCommitDate :: ExpQ
gitCommitDate =
String -> ExpQ
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 ["log", "HEAD", "-1", "--format=%cd"] "UNKNOWN" IndexUsed
IdxNotUsed