@@ -1,6 +1,3 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MultiWayIf #-}
3−
41-- |
52-- Module : $Header$
63-- Copyright : (c) 2015 Adam C. Foltzer
@@ -20,28 +17,18 @@
2017-- > panic :: String -> a
2118-- > panic msg = error panicMsg
2219-- > where panicMsg =
23−-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
24−-- > , " (", $(gitCommitDate), ")"
25−-- > , " (", $(gitCommitCount), " commits in HEAD)"
26−-- > , dirty, "] ", msg ]
20+-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash), dirty, "] ", msg ]
2721-- > dirty | $(gitDirty) = " (uncommitted files present)"
2822-- > | otherwise = ""
2923-- >
3024-- > main = panic "oh no!"
3125--
3226-- > % cabal exec runhaskell Example.hs
33−-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no!
27+-- > Example.hs: [panic master@4a0a592c37ad908889bd2a7a411923a903ed05a3 (uncommitted files present)] oh no!
3428
35−module Development.GitRev
36− ( gitBranch
37− , gitCommitCount
38− , gitCommitDate
39− , gitDescribe
40− , gitDirty
41− , gitDirtyTracked
42− , gitHash
43− ) where
29+module Development.GitRev (gitHash, gitBranch, gitDirty) where
4430
31+import Control.Applicative
4532import Control.Exception
4633import Control.Monad
4734import Data.Maybe
@@ -52,21 +39,18 @@ import System.Exit
5239import System.FilePath
5340import System.Process
5441
55−import Prelude ()
56−import Prelude.Compat
57−
5842-- | Run git with the given arguments and no stdin, returning the
5943-- stdout output. If git isn't available or something goes wrong,
6044-- return the second argument.
61−runGit :: [String] -> String -> IndexUsed -> Q String
62−runGit args def useIdx = do
45+runGit :: [String] -> String -> Q String
46+runGit args def = do
6347 let oops :: SomeException -> IO (ExitCode, String, String)
6448 oops _e = return (ExitFailure 1, def, "")
6549 gitFound <- runIO $ isJust <$> findExecutable "git"
6650 if gitFound
6751 then do
6852 -- a lot of bookkeeping to record the right dependencies
69− pwd <- runIO getDotGit
53+ pwd <- runIO getCurrentDirectory
7054 let hd = pwd </> ".git" </> "HEAD"
7155 index = pwd </> ".git" </> "index"
7256 packedRefs = pwd </> ".git" </> "packed-refs"
@@ -74,7 +58,8 @@ runGit args def useIdx = do
7458 when hdExists $ do
7559 -- the HEAD file either contains the hash of a detached head
7660 -- or a pointer to the file that contains the hash of the head
77− splitAt 5 `fmap` runIO (readFile hd) >>= \case
61+ hdRef <- runIO $ readFile hd
62+ case splitAt 5 hdRef of
7863 -- pointer to ref
7964 ("ref: ", relRef) -> do
8065 let ref = pwd </> ".git" </> relRef
@@ -84,7 +69,7 @@ runGit args def useIdx = do
8469 _hash -> addDependentFile hd
8570 -- add the index if it exists to set the dirty flag
8671 indexExists <- runIO $ doesFileExist index
87− when (indexExists && useIdx == IdxUsed) $ addDependentFile index
72+ when indexExists $ addDependentFile index
8873 -- if the refs have been packed, the info we're looking for
8974 -- might be in that file rather than the one-file-per-ref case
9075 -- handled above
@@ -97,84 +82,24 @@ runGit args def useIdx = do
9782 ExitFailure _ -> return def
9883 else return def
9984
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−
13585-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
13686-- a git repository
13787gitHash :: ExpQ
13888gitHash =
139− stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
89+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN"
14090
14191-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
14292-- if not in a git repository. For detached heads, this will just be
14393-- "HEAD"
14494gitBranch :: ExpQ
14595gitBranch =
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
96+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN"
15397
15498-- | Return @True@ if there are non-committed files present in the
15599-- repository
156100gitDirty :: ExpQ
157101gitDirty = do
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
102+ output <- runGit ["status", "--porcelain"] ""
168103 case output of
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
104+ "" -> conE $ mkName "Prelude.False"
105+ _ -> conE $ mkName "Prelude.True"