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