@@ -1,3 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
3+
14-- |
25-- Module : $Header$
36-- Copyright : (c) 2015 Adam C. Foltzer
@@ -17,18 +20,28 @@
1720-- > panic :: String -> a
1821-- > panic msg = error panicMsg
1922-- > where panicMsg =
20−-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash), dirty, "] ", msg ]
23+-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
24+-- > , " (", $(gitCommitDate), ")"
25+-- > , " (", $(gitCommitCount), " commits in HEAD)"
26+-- > , dirty, "] ", msg ]
2127-- > dirty | $(gitDirty) = " (uncommitted files present)"
2228-- > | otherwise = ""
2329-- >
2430-- > main = panic "oh no!"
2531--
2632-- > % cabal exec runhaskell Example.hs
27−-- > Example.hs: [panic master@4a0a592c37ad908889bd2a7a411923a903ed05a3 (uncommitted files present)] oh no!
33+-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no!
2834
29−module Development.GitRev (gitHash, gitBranch, gitDirty) where
35+module Development.GitRev
36+ ( gitBranch
37+ , gitCommitCount
38+ , gitCommitDate
39+ , gitDescribe
40+ , gitDirty
41+ , gitDirtyTracked
42+ , gitHash
43+ ) where
3044
31−import Control.Applicative
3245import Control.Exception
3346import Control.Monad
3447import Data.Maybe
@@ -39,18 +52,21 @@ import System.Exit
3952import System.FilePath
4053import System.Process
4154
55+import Prelude ()
56+import Prelude.Compat
57+
4258-- | Run git with the given arguments and no stdin, returning the
4359-- stdout output. If git isn't available or something goes wrong,
4460-- return the second argument.
45−runGit :: [String] -> String -> Q String
46−runGit args def = do
61+runGit :: [String] -> String -> IndexUsed -> Q String
62+runGit args def useIdx = do
4763 let oops :: SomeException -> IO (ExitCode, String, String)
4864 oops _e = return (ExitFailure 1, def, "")
4965 gitFound <- runIO $ isJust <$> findExecutable "git"
5066 if gitFound
5167 then do
5268 -- a lot of bookkeeping to record the right dependencies
53− pwd <- runIO getCurrentDirectory
69+ pwd <- runIO getDotGit
5470 let hd = pwd </> ".git" </> "HEAD"
5571 index = pwd </> ".git" </> "index"
5672 packedRefs = pwd </> ".git" </> "packed-refs"
@@ -58,8 +74,7 @@ runGit args def = do
5874 when hdExists $ do
5975 -- the HEAD file either contains the hash of a detached head
6076 -- or a pointer to the file that contains the hash of the head
61− hdRef <- runIO $ readFile hd
62− case splitAt 5 hdRef of
77+ splitAt 5 `fmap` runIO (readFile hd) >>= \case
6378 -- pointer to ref
6479 ("ref: ", relRef) -> do
6580 let ref = pwd </> ".git" </> relRef
@@ -69,7 +84,7 @@ runGit args def = do
6984 _hash -> addDependentFile hd
7085 -- add the index if it exists to set the dirty flag
7186 indexExists <- runIO $ doesFileExist index
72− when indexExists $ addDependentFile index
87+ when (indexExists && useIdx == IdxUsed) $ addDependentFile index
7388 -- if the refs have been packed, the info we're looking for
7489 -- might be in that file rather than the one-file-per-ref case
7590 -- handled above
@@ -82,24 +97,84 @@ runGit args def = do
8297 ExitFailure _ -> return def
8398 else return def
8499
100+-- | Determine where our @.git@ directory is, in case we're in a
101+-- submodule.
102+getDotGit :: IO FilePath
103+getDotGit = do
104+ pwd <- getGitRoot
105+ let dotGit = pwd </> ".git"
106+ oops = return dotGit -- it's gonna fail, that's fine
107+ isDir <- doesDirectoryExist dotGit
108+ isFile <- doesFileExist dotGit
109+ if | isDir -> return dotGit
110+ | not isFile -> oops
111+ | isFile ->
112+ splitAt 8 `fmap` readFile dotGit >>= \case
113+ ("gitdir: ", relDir) -> do
114+ isRelDir <- doesDirectoryExist relDir
115+ if isRelDir
116+ then return relDir
117+ else oops
118+ _ -> oops
119+
120+-- | Get the root directory of the Git repo.
121+getGitRoot :: IO FilePath
122+getGitRoot = do
123+ pwd <- getCurrentDirectory
124+ (code, out, _) <-
125+ readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
126+ case code of
127+ ExitSuccess -> return $ takeWhile (/= '\n') out
128+ ExitFailure _ -> return pwd -- later steps will fail, that's fine
129+
130+-- | Type to flag if the git index is used or not in a call to runGit
131+data IndexUsed = IdxUsed -- ^ The git index is used
132+ | IdxNotUsed -- ^ The git index is /not/ used
133+ deriving (Eq)
134+
85135-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
86136-- a git repository
87137gitHash :: ExpQ
88138gitHash =
89− stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN"
139+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
90140
91141-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
92142-- if not in a git repository. For detached heads, this will just be
93143-- "HEAD"
94144gitBranch :: ExpQ
95145gitBranch =
96− stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN"
146+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed
147+
148+-- | Return the long git description for the current git commit, or
149+-- @UNKNOWN@ if not in a git repository.
150+gitDescribe :: ExpQ
151+gitDescribe =
152+ stringE =<< runGit ["describe", "--long", "--always"] "UNKNOWN" IdxNotUsed
97153
98154-- | Return @True@ if there are non-committed files present in the
99155-- repository
100156gitDirty :: ExpQ
101157gitDirty = do
102− output <- runGit ["status", "--porcelain"] ""
158+ output <- runGit ["status", "--porcelain"] "" IdxUsed
159+ case output of
160+ "" -> conE falseName
161+ _ -> conE trueName
162+
163+-- | Return @True@ if there are non-commited changes to tracked files
164+-- present in the repository
165+gitDirtyTracked :: ExpQ
166+gitDirtyTracked = do
167+ output <- runGit ["status", "--porcelain","--untracked-files=no"] "" IdxUsed
103168 case output of
104− "" -> conE $ mkName "Prelude.False"
105− _ -> conE $ mkName "Prelude.True"
169+ "" -> conE falseName
170+ _ -> conE trueName
171+
172+-- | Return the number of commits in the current head
173+gitCommitCount :: ExpQ
174+gitCommitCount =
175+ stringE =<< runGit ["rev-list", "HEAD", "--count"] "UNKNOWN" IdxNotUsed
176+
177+-- | Return the commit date of the current head
178+gitCommitDate :: ExpQ
179+gitCommitDate =
180+ stringE =<< runGit ["log", "HEAD", "-1", "--format=%cd"] "UNKNOWN" IdxNotUsed