@@ -1,3 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
2-- Module : $Header$
5-- Module : $Header$
3-- Copyright : (c) 2015 Adam C. Foltzer
6-- Copyright : (c) 2015 Adam C. Foltzer
@@ -18,6 +21,7 @@
18-- > panic msg = error panicMsg
21-- > panic msg = error panicMsg
19-- > where panicMsg =
22-- > where panicMsg =
20-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
23-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
24+-- > , " (", $(gitCommitDate), ")"
21-- > , " (", $(gitCommitCount), " commits in HEAD)"
25-- > , " (", $(gitCommitCount), " commits in HEAD)"
22-- > , dirty, "] ", msg ]
26-- > , dirty, "] ", msg ]
23-- > dirty | $(gitDirty) = " (uncommitted files present)"
27-- > dirty | $(gitDirty) = " (uncommitted files present)"
@@ -26,11 +30,18 @@
26-- > main = panic "oh no!"
30-- > main = panic "oh no!"
28-- > % cabal exec runhaskell Example.hs
32-- > % cabal exec runhaskell Example.hs
29−-- > Example.hs: [panic master@2702e69355c978805064543489c351b61ac6760b (6 commits in HEAD) (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!
31−module Development.GitRev (gitHash, gitBranch, gitDirty, gitCommitCount) where
35+module Development.GitRev
33−import Control.Applicative
34import Control.Exception
45import Control.Exception
35import Control.Monad
46import Control.Monad
36import Data.Maybe
47import Data.Maybe
@@ -41,18 +52,21 @@ import System.Exit
41import System.FilePath
52import System.FilePath
42import System.Process
53import System.Process
44-- | Run git with the given arguments and no stdin, returning the
58-- | Run git with the given arguments and no stdin, returning the
45-- stdout output. If git isn't available or something goes wrong,
59-- stdout output. If git isn't available or something goes wrong,
46-- return the second argument.
60-- return the second argument.
47−runGit :: [String] -> String -> Q String
61+runGit :: [String] -> String -> IndexUsed -> Q String
48−runGit args def = do
62+runGit args def useIdx = do
49 let oops :: SomeException -> IO (ExitCode, String, String)
63 let oops :: SomeException -> IO (ExitCode, String, String)
50 oops _e = return (ExitFailure 1, def, "")
64 oops _e = return (ExitFailure 1, def, "")
51 gitFound <- runIO $ isJust <$> findExecutable "git"
65 gitFound <- runIO $ isJust <$> findExecutable "git"
52 if gitFound
66 if gitFound
54 -- a lot of bookkeeping to record the right dependencies
68 -- a lot of bookkeeping to record the right dependencies
55− pwd <- runIO getCurrentDirectory
69+ pwd <- runIO getDotGit
56 let hd = pwd </> ".git" </> "HEAD"
70 let hd = pwd </> ".git" </> "HEAD"
57 index = pwd </> ".git" </> "index"
71 index = pwd </> ".git" </> "index"
58 packedRefs = pwd </> ".git" </> "packed-refs"
72 packedRefs = pwd </> ".git" </> "packed-refs"
@@ -60,8 +74,7 @@ runGit args def = do
60 when hdExists $ do
74 when hdExists $ do
61 -- the HEAD file either contains the hash of a detached head
75 -- the HEAD file either contains the hash of a detached head
62 -- or a pointer to the file that contains the hash of the head
76 -- or a pointer to the file that contains the hash of the head
63− hdRef <- runIO $ readFile hd
77+ splitAt 5 `fmap` runIO (readFile hd) >>= \case
64− case splitAt 5 hdRef of
65 -- pointer to ref
78 -- pointer to ref
66 ("ref: ", relRef) -> do
79 ("ref: ", relRef) -> do
67 let ref = pwd </> ".git" </> relRef
80 let ref = pwd </> ".git" </> relRef
@@ -71,7 +84,7 @@ runGit args def = do
71 _hash -> addDependentFile hd
84 _hash -> addDependentFile hd
72 -- add the index if it exists to set the dirty flag
85 -- add the index if it exists to set the dirty flag
73 indexExists <- runIO $ doesFileExist index
86 indexExists <- runIO $ doesFileExist index
74− when indexExists $ addDependentFile index
87+ when (indexExists && useIdx == IdxUsed) $ addDependentFile index
75 -- if the refs have been packed, the info we're looking for
88 -- if the refs have been packed, the info we're looking for
76 -- might be in that file rather than the one-file-per-ref case
89 -- might be in that file rather than the one-file-per-ref case
77 -- handled above
90 -- handled above
@@ -84,29 +97,84 @@ runGit args def = do
84 ExitFailure _ -> return def
97 ExitFailure _ -> return def
85 else return def
98 else return def
100+-- | Determine where our @.git@ directory is, in case we're in a
102+getDotGit :: IO FilePath
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
112+ splitAt 8 `fmap` readFile dotGit >>= \case
113+ ("gitdir: ", relDir) -> do
114+ isRelDir <- doesDirectoryExist relDir
120+-- | Get the root directory of the Git repo.
121+getGitRoot :: IO FilePath
123+ pwd <- getCurrentDirectory
125+ readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
127+ ExitSuccess -> return $ takeWhile (/= '\n') out
128+ ExitFailure _ -> return pwd -- later steps will fail, that's fine
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
87-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
135-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
88-- a git repository
136-- a git repository
89gitHash :: ExpQ
137gitHash :: ExpQ
91− stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN"
139+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
93-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
141-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
94-- if not in a git repository. For detached heads, this will just be
142-- if not in a git repository. For detached heads, this will just be
96gitBranch :: ExpQ
144gitBranch :: ExpQ
97gitBranch =
145gitBranch =
98− stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN"
146+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed
148+-- | Return the long git description for the current git commit, or
149+-- @UNKNOWN@ if not in a git repository.
152+ stringE =<< runGit ["describe", "--long", "--always"] "UNKNOWN" IdxNotUsed
100-- | Return @True@ if there are non-committed files present in the
154-- | Return @True@ if there are non-committed files present in the
101-- repository
155-- repository
102gitDirty :: ExpQ
156gitDirty :: ExpQ
103gitDirty = do
157gitDirty = do
104− output <- runGit ["status", "--porcelain"] ""
158+ output <- runGit ["status", "--porcelain"] "" IdxUsed
160+ "" -> conE falseName
163+-- | Return @True@ if there are non-commited changes to tracked files
164+-- present in the repository
165+gitDirtyTracked :: ExpQ
167+ output <- runGit ["status", "--porcelain","--untracked-files=no"] "" IdxUsed
105 case output of
168 case output of
106− "" -> conE $ mkName "Prelude.False"
169+ "" -> conE falseName
107− _ -> conE $ mkName "Prelude.True"
170+ _ -> conE trueName
109-- | Return the number of commits in the current head
172-- | Return the number of commits in the current head
110gitCommitCount :: ExpQ
173gitCommitCount :: ExpQ
111gitCommitCount =
174gitCommitCount =
112− stringE =<< runGit ["rev-list", "HEAD", "--count"] "UNKNOWN"
175+ stringE =<< runGit ["rev-list", "HEAD", "--count"] "UNKNOWN" IdxNotUsed
177+-- | Return the commit date of the current head
178+gitCommitDate :: ExpQ
180+ stringE =<< runGit ["log", "HEAD", "-1", "--format=%cd"] "UNKNOWN" IdxNotUsed