9145019..master · typeable/gitrev

git.iko.soy/typeable/gitrev

on master help sign in

README.md+5−5

since splitsnapshots

unifiedsplit

@@ -11,13 +11,13 @@ places the current git hash might be stored:

111. Detached HEAD: the hash is in `.git/HEAD`

122. On a branch or tag: the hash is in a file pointed to by `.git/HEAD`

13in a location like `.git/refs/heads`

14−3. On a branch or tag but in a repository with packed refs: the hash is

14+3. On a branch or tag but in a repository with packed refs: the hash

15−in `.git/packed-refs`

15+is in `.git/packed-refs`

16+4. In any of the above situations, if the current repo is checked out

17+as a submodule, follow the reference to its `.git` directory first

17These files are added as dependencies to modules that use `GitRev`, and

19These files are added as dependencies to modules that use `GitRev`, and

18so the module should be rebuilt automatically whenever these files

20so the module should be rebuilt automatically whenever these files

19change.

21change.

21−These situations all arise under normal development workflows, but

22−there might be further scenarios that cause problems. Let me know if

23+If you run into further scenarios that cause problems, let me know!

23−you run into them!

gitrev.cabal+4−1

@@ -1,5 +1,5 @@

1name: gitrev

2−version: 1.2.0

2+version: 1.3.1

3synopsis: Compile git revision info into Haskell projects

4homepage: https://github.com/acfoltzer/gitrev

5license: BSD3

@@ -9,6 +9,7 @@ maintainer: acfoltzer@galois.com

9category: Development

10build-type: Simple

11cabal-version: >=1.10

12+tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2

12description: Some handy Template Haskell splices for including the current git hash and branch in the code of your project. Useful for including in panic messages, @--version@ output, or diagnostic info for more informative bug reports.

13description: Some handy Template Haskell splices for including the current git hash and branch in the code of your project. Useful for including in panic messages, @--version@ output, or diagnostic info for more informative bug reports.

14source-repository head

15source-repository head

@@ -17,10 +18,12 @@ source-repository head

18library

19library

19 build-depends: base >= 4.6 && < 5,

20 build-depends: base >= 4.6 && < 5,

21+ base-compat >= 0.6.0,

20 directory,

22 directory,

21 filepath,

23 filepath,

22 template-haskell,

24 template-haskell,

23 process

25 process

24 hs-source-dirs: src

26 hs-source-dirs: src

27+ ghc-options: -Wall

25 default-language: Haskell2010

28 default-language: Haskell2010

26 exposed-modules: Development.GitRev

29 exposed-modules: Development.GitRev

src/Development/GitRev.hs+62−5

@@ -1,3 +1,6 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE MultiWayIf #-}

1-- |

4-- |

2-- Module : $Header$

5-- Module : $Header$

@@ -29,9 +32,16 @@

29-- > % cabal exec runhaskell Example.hs

32-- > % cabal exec runhaskell Example.hs

30-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 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!

32−module Development.GitRev (gitHash, gitBranch, gitDirty, gitCommitCount, gitCommitDate) where

35+module Development.GitRev

36+ ( gitBranch

37+ , gitCommitCount

38+ , gitCommitDate

39+ , gitDescribe

40+ , gitDirty

41+ , gitDirtyTracked

42+ , gitHash

43+ ) where

34−import Control.Applicative

35import Control.Exception

45import Control.Exception

36import Control.Monad

46import Control.Monad

37import Data.Maybe

47import Data.Maybe

@@ -42,6 +52,9 @@ import System.Exit

42import System.FilePath

52import System.FilePath

43import System.Process

53import System.Process

55+import Prelude ()

56+import Prelude.Compat

57+

45-- | Run git with the given arguments and no stdin, returning the

58-- | Run git with the given arguments and no stdin, returning the

46-- stdout output. If git isn't available or something goes wrong,

59-- stdout output. If git isn't available or something goes wrong,

47-- return the second argument.

60-- return the second argument.

@@ -53,7 +66,7 @@ runGit args def useIdx = do

53 if gitFound

66 if gitFound

54 then do

67 then do

55 -- a lot of bookkeeping to record the right dependencies

68 -- a lot of bookkeeping to record the right dependencies

56− pwd <- runIO getCurrentDirectory

69+ pwd <- runIO getDotGit

57 let hd = pwd </> ".git" </> "HEAD"

70 let hd = pwd </> ".git" </> "HEAD"

58 index = pwd </> ".git" </> "index"

71 index = pwd </> ".git" </> "index"

59 packedRefs = pwd </> ".git" </> "packed-refs"

72 packedRefs = pwd </> ".git" </> "packed-refs"

@@ -61,8 +74,7 @@ runGit args def useIdx = do

61 when hdExists $ do

74 when hdExists $ do

62 -- the HEAD file either contains the hash of a detached head

75 -- the HEAD file either contains the hash of a detached head

63 -- 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

64− hdRef <- runIO $ readFile hd

77+ splitAt 5 `fmap` runIO (readFile hd) >>= \case

65− case splitAt 5 hdRef of

66 -- pointer to ref

78 -- pointer to ref

67 ("ref: ", relRef) -> do

79 ("ref: ", relRef) -> do

68 let ref = pwd </> ".git" </> relRef

80 let ref = pwd </> ".git" </> relRef

@@ -85,6 +97,36 @@ runGit args def useIdx = do

85 ExitFailure _ -> return def

97 ExitFailure _ -> return def

86 else return def

98 else return def

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+

88-- | Type to flag if the git index is used or not in a call to runGit

130-- | Type to flag if the git index is used or not in a call to runGit

89data IndexUsed = IdxUsed -- ^ The git index is used

131data IndexUsed = IdxUsed -- ^ The git index is used

90 | IdxNotUsed -- ^ The git index is /not/ used

132 | IdxNotUsed -- ^ The git index is /not/ used

@@ -103,6 +145,12 @@ gitBranch :: ExpQ

103gitBranch =

145gitBranch =

104 stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed

146 stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed

105

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

153+

106-- | Return @True@ if there are non-committed files present in the

154-- | Return @True@ if there are non-committed files present in the

107-- repository

155-- repository

108gitDirty :: ExpQ

156gitDirty :: ExpQ

@@ -112,6 +160,15 @@ gitDirty = do

112 "" -> conE falseName

160 "" -> conE falseName

113 _ -> conE trueName

161 _ -> conE trueName

114

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

168+ case output of

169+ "" -> conE falseName

170+ _ -> conE trueName

171+

115-- | Return the number of commits in the current head

172-- | Return the number of commits in the current head

116gitCommitCount :: ExpQ

173gitCommitCount :: ExpQ

117gitCommitCount =

174gitCommitCount =