@@ -0,0 +1,105 @@
3+-- Copyright : (c) 2015 Adam C. Foltzer
5+-- Maintainer : acfoltzer@galois.com
6+-- Stability : provisional
7+-- Portability : portable
9+-- Some handy Template Haskell splices for including the current git
10+-- hash and branch in the code of your project. Useful for including
11+-- in panic messages, @--version@ output, or diagnostic info for more
12+-- informative bug reports.
14+-- > {-# LANGUAGE TemplateHaskell #-}
15+-- > import Development.GitRev
17+-- > panic :: String -> a
18+-- > panic msg = error panicMsg
20+-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash), dirty, "] ", msg ]
21+-- > dirty | $(gitDirty) = " (uncommitted files present)"
24+-- > main = panic "oh no!"
26+-- > % cabal exec runhaskell Example.hs
27+-- > Example.hs: [panic master@4a0a592c37ad908889bd2a7a411923a903ed05a3 (uncommitted files present)] oh no!
29+module Development.GitRev (gitHash, gitBranch, gitDirty) where
31+import Control.Applicative
32+import Control.Exception
35+import Language.Haskell.TH
36+import Language.Haskell.TH.Syntax
37+import System.Directory
39+import System.FilePath
42+-- | Run git with the given arguments and no stdin, returning the
43+-- stdout output. If git isn't available or something goes wrong,
44+-- return the second argument.
45+runGit :: [String] -> String -> Q String
47+ let oops :: SomeException -> IO (ExitCode, String, String)
48+ oops _e = return (ExitFailure 1, def, "")
49+ gitFound <- runIO $ isJust <$> findExecutable "git"
52+ -- a lot of bookkeeping to record the right dependencies
53+ pwd <- runIO getCurrentDirectory
54+ let hd = pwd </> ".git" </> "HEAD"
55+ index = pwd </> ".git" </> "index"
56+ packedRefs = pwd </> ".git" </> "packed-refs"
57+ hdExists <- runIO $ doesFileExist hd
59+ -- the HEAD file either contains the hash of a detached head
60+ -- or a pointer to the file that contains the hash of the head
61+ hdRef <- runIO $ readFile hd
62+ case splitAt 5 hdRef of
64+ ("ref: ", relRef) -> do
65+ let ref = pwd </> ".git" </> relRef
66+ refExists <- runIO $ doesFileExist ref
67+ when refExists $ addDependentFile ref
69+ _hash -> addDependentFile hd
70+ -- add the index if it exists to set the dirty flag
71+ indexExists <- runIO $ doesFileExist index
72+ when indexExists $ addDependentFile index
73+ -- if the refs have been packed, the info we're looking for
74+ -- might be in that file rather than the one-file-per-ref case
76+ packedExists <- runIO $ doesFileExist packedRefs
77+ when packedExists $ addDependentFile packedRefs
79+ (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
81+ ExitSuccess -> return (takeWhile (/= '\n') out)
82+ ExitFailure _ -> return def
85+-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
89+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN"
91+-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
92+-- if not in a git repository. For detached heads, this will just be
96+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN"
98+-- | Return @True@ if there are non-committed files present in the
102+ output <- runGit ["status", "--porcelain"] ""
104+ "" -> conE $ mkName "Prelude.False"
105+ _ -> conE $ mkName "Prelude.True"