@@ -1,6 +1,3 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MultiWayIf #-}
5-- Module : $Header$
2-- Module : $Header$
6-- Copyright : (c) 2015 Adam C. Foltzer
3-- Copyright : (c) 2015 Adam C. Foltzer
@@ -20,28 +17,18 @@
20-- > panic :: String -> a
17-- > panic :: String -> a
21-- > panic msg = error panicMsg
18-- > panic msg = error panicMsg
22-- > where panicMsg =
19-- > where panicMsg =
23−-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
20+-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash), dirty, "] ", msg ]
24−-- > , " (", $(gitCommitDate), ")"
25−-- > , " (", $(gitCommitCount), " commits in HEAD)"
26−-- > , dirty, "] ", msg ]
27-- > dirty | $(gitDirty) = " (uncommitted files present)"
21-- > dirty | $(gitDirty) = " (uncommitted files present)"
28-- > | otherwise = ""
22-- > | otherwise = ""
30-- > main = panic "oh no!"
24-- > main = panic "oh no!"
32-- > % cabal exec runhaskell Example.hs
26-- > % 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!
35−module Development.GitRev
29+module Development.GitRev (gitHash, gitBranch, gitDirty) where
31+import Control.Applicative
45import Control.Exception
32import Control.Exception
46import Control.Monad
33import Control.Monad
47import Data.Maybe
34import Data.Maybe
@@ -52,21 +39,18 @@ import System.Exit
52import System.FilePath
39import System.FilePath
53import System.Process
40import System.Process
58-- | Run git with the given arguments and no stdin, returning the
42-- | Run git with the given arguments and no stdin, returning the
59-- stdout output. If git isn't available or something goes wrong,
43-- stdout output. If git isn't available or something goes wrong,
60-- return the second argument.
44-- return the second argument.
61−runGit :: [String] -> String -> IndexUsed -> Q String
45+runGit :: [String] -> String -> Q String
62−runGit args def useIdx = do
46+runGit args def = do
63 let oops :: SomeException -> IO (ExitCode, String, String)
47 let oops :: SomeException -> IO (ExitCode, String, String)
64 oops _e = return (ExitFailure 1, def, "")
48 oops _e = return (ExitFailure 1, def, "")
65 gitFound <- runIO $ isJust <$> findExecutable "git"
49 gitFound <- runIO $ isJust <$> findExecutable "git"
66 if gitFound
50 if gitFound
68 -- a lot of bookkeeping to record the right dependencies
52 -- a lot of bookkeeping to record the right dependencies
69− pwd <- runIO getDotGit
53+ pwd <- runIO getCurrentDirectory
70 let hd = pwd </> ".git" </> "HEAD"
54 let hd = pwd </> ".git" </> "HEAD"
71 index = pwd </> ".git" </> "index"
55 index = pwd </> ".git" </> "index"
72 packedRefs = pwd </> ".git" </> "packed-refs"
56 packedRefs = pwd </> ".git" </> "packed-refs"
@@ -74,7 +58,8 @@ runGit args def useIdx = do
74 when hdExists $ do
58 when hdExists $ do
75 -- the HEAD file either contains the hash of a detached head
59 -- the HEAD file either contains the hash of a detached head
76 -- or a pointer to the file that contains the hash of the head
60 -- 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
78 -- pointer to ref
63 -- pointer to ref
79 ("ref: ", relRef) -> do
64 ("ref: ", relRef) -> do
80 let ref = pwd </> ".git" </> relRef
65 let ref = pwd </> ".git" </> relRef
@@ -84,7 +69,7 @@ runGit args def useIdx = do
84 _hash -> addDependentFile hd
69 _hash -> addDependentFile hd
85 -- add the index if it exists to set the dirty flag
70 -- add the index if it exists to set the dirty flag
86 indexExists <- runIO $ doesFileExist index
71 indexExists <- runIO $ doesFileExist index
87− when (indexExists && useIdx == IdxUsed) $ addDependentFile index
72+ when indexExists $ addDependentFile index
88 -- if the refs have been packed, the info we're looking for
73 -- if the refs have been packed, the info we're looking for
89 -- might be in that file rather than the one-file-per-ref case
74 -- might be in that file rather than the one-file-per-ref case
90 -- handled above
75 -- handled above
@@ -97,84 +82,24 @@ runGit args def useIdx = do
97 ExitFailure _ -> return def
82 ExitFailure _ -> return def
98 else return def
83 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
135-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
85-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
136-- a git repository
86-- a git repository
137gitHash :: ExpQ
87gitHash :: ExpQ
139− stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
89+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN"
141-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
91-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
142-- if not in a git repository. For detached heads, this will just be
92-- if not in a git repository. For detached heads, this will just be
144gitBranch :: ExpQ
94gitBranch :: ExpQ
145gitBranch =
95gitBranch =
146− stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed
96+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN"
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
154-- | Return @True@ if there are non-committed files present in the
98-- | Return @True@ if there are non-committed files present in the
155-- repository
99-- repository
156gitDirty :: ExpQ
100gitDirty :: ExpQ
157gitDirty = do
101gitDirty = do
158− output <- runGit ["status", "--porcelain"] "" IdxUsed
102+ output <- runGit ["status", "--porcelain"] ""
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
168 case output of
103 case output of
169− "" -> conE falseName
104+ "" -> conE $ mkName "Prelude.False"
170− _ -> conE trueName
105+ _ -> conE $ mkName "Prelude.True"
172−-- | Return the number of commits in the current head
173−gitCommitCount :: ExpQ
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