    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE MultiWayIf #-}

    -- |
    -- Module      :  $Header$
    -- Copyright   :  (c) 2015 Adam C. Foltzer
    -- License     :  BSD3
    -- Maintainer  :  acfoltzer@galois.com
    -- Stability   :  provisional
    -- Portability :  portable
    --
    -- 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.
    --
    -- > {-# LANGUAGE TemplateHaskell #-}
    -- > import Development.GitRev
    -- >
    -- > panic :: String -> a
    -- > panic msg = error panicMsg
    -- >   where panicMsg =
    -- >           concat [ "[panic ", $(gitBranch), "@", $(gitHash)
    -- >                  , " (", $(gitCommitDate), ")"
    -- >                  , " (", $(gitCommitCount), " commits in HEAD)"
    -- >                  , dirty, "] ", msg ]
    -- >         dirty | $(gitDirty) = " (uncommitted files present)"
    -- >               | otherwise   = ""
    -- >
    -- > main = panic "oh no!"
    --
    -- > % cabal exec runhaskell Example.hs
    -- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no!

    module Development.GitRev
      ( gitBranch
      , gitCommitCount
      , gitCommitDate
      , gitDescribe
      , gitDirty
      , gitDirtyTracked
      , gitHash
      ) where

    import Control.Exception
    import Control.Monad
    import Data.Maybe
    import Language.Haskell.TH
    import Language.Haskell.TH.Syntax
    import System.Directory
    import System.Exit
    import System.FilePath
    import System.Process

    import Prelude ()
    import Prelude.Compat

    -- | Run git with the given arguments and no stdin, returning the
    -- stdout output. If git isn't available or something goes wrong,
    -- return the second argument.
    runGit :: [String] -> String -> IndexUsed -> Q String
    runGit :: [String] -> String -> IndexUsed -> Q String
    runGit [String]
    args String
    def IndexUsed
    useIdx = do
      let oops :: SomeException -> IO (ExitCode, String, String)
          oops :: SomeException -> IO (ExitCode, String, String)
    oops SomeException
    _e = (ExitCode, String, String) -> IO (ExitCode, String, String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> ExitCode
    ExitFailure Int
    1, String
    def, String
    "")
      gitFound <- IO Bool -> Q Bool
    forall a. IO a -> Q a
    runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
    forall a b. (a -> b) -> a -> b
    $ Maybe String -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO (Maybe String)
    findExecutable String
    "git"
      if gitFound
        then do
          -- a lot of bookkeeping to record the right dependencies
          pwd <- runIO getDotGit
          let hd         = String
    pwd String -> String -> String
    </> String
    ".git" String -> String -> String
    </> String
    "HEAD"
              index      = String
    pwd String -> String -> String
    </> String
    ".git" String -> String -> String
    </> String
    "index"
              packedRefs = String
    pwd String -> String -> String
    </> String
    ".git" String -> String -> String
    </> String
    "packed-refs"
          hdExists  <- runIO $ doesFileExist hd
          when hdExists $ do
            -- the HEAD file either contains the hash of a detached head
            -- or a pointer to the file that contains the hash of the head
            splitAt 5 `fmap` runIO (readFile hd) >>= \case
              -- pointer to ref
              (String
    "ref: ", String
    relRef) -> do
                let ref :: String
    ref = String
    pwd String -> String -> String
    </> String
    ".git" String -> String -> String
    </> String
    relRef
                refExists <- IO Bool -> Q Bool
    forall a. IO a -> Q a
    runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
    forall a b. (a -> b) -> a -> b
    $ String -> IO Bool
    doesFileExist String
    ref
                when refExists $ addDependentFile ref
              -- detached head
              (String, String)
    _hash -> String -> Q ()
    addDependentFile String
    hd
          -- add the index if it exists to set the dirty flag
          indexExists <- runIO $ doesFileExist index
          when (indexExists && useIdx == IdxUsed) $ addDependentFile index
          -- if the refs have been packed, the info we're looking for
          -- might be in that file rather than the one-file-per-ref case
          -- handled above
          packedExists <- runIO $ doesFileExist packedRefs
          when packedExists $ addDependentFile packedRefs
          runIO $ do
            (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
            case code of
              ExitCode
    ExitSuccess   -> String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n') String
    out)
              ExitFailure Int
    _ -> String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    def
        else return def

    -- | Determine where our @.git@ directory is, in case we're in a
    -- submodule.
    getDotGit :: IO FilePath
    getDotGit :: IO String
    getDotGit = do
      pwd <- IO String
    getGitRoot
      let dotGit = String
    pwd String -> String -> String
    </> String
    ".git"
          oops = String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    dotGit -- it's gonna fail, that's fine
      isDir <- doesDirectoryExist dotGit
      isFile <- doesFileExist dotGit
      if | isDir -> return dotGit
         | not isFile -> oops
         | isFile ->
             splitAt 8 `fmap` readFile dotGit >>= \case
               (String
    "gitdir: ", String
    relDir) -> do
                 isRelDir <- String -> IO Bool
    doesDirectoryExist String
    relDir
                 if isRelDir
                   then return relDir
                   else oops
               (String, String)
    _ -> IO String
    oops

    -- | Get the root directory of the Git repo.
    getGitRoot :: IO FilePath
    getGitRoot :: IO String
    getGitRoot = do
      pwd <- IO String
    getCurrentDirectory
      (code, out, _) <-
        readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
      case code of
        ExitCode
    ExitSuccess   -> String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n') String
    out
        ExitFailure Int
    _ -> String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    pwd -- later steps will fail, that's fine

    -- | Type to flag if the git index is used or not in a call to runGit
    data IndexUsed = IdxUsed -- ^ The git index is used
                   | IdxNotUsed -- ^ The git index is /not/ used
        deriving (IndexUsed -> IndexUsed -> Bool
    (IndexUsed -> IndexUsed -> Bool)
    -> (IndexUsed -> IndexUsed -> Bool) -> Eq IndexUsed
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: IndexUsed -> IndexUsed -> Bool
    == :: IndexUsed -> IndexUsed -> Bool
    $c/= :: IndexUsed -> IndexUsed -> Bool
    /= :: IndexUsed -> IndexUsed -> Bool
    Eq)

    -- | Return the hash of the current git commit, or @UNKNOWN@ if not in
    -- a git repository
    gitHash :: ExpQ
    gitHash :: ExpQ
    gitHash =
      String -> ExpQ
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> ExpQ) -> Q String -> ExpQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [String] -> String -> IndexUsed -> Q String
    runGit [String
    "rev-parse", String
    "HEAD"] String
    "UNKNOWN" IndexUsed
    IdxNotUsed

    -- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
    -- if not in a git repository. For detached heads, this will just be
    -- "HEAD"
    gitBranch :: ExpQ
    gitBranch :: ExpQ
    gitBranch =
      String -> ExpQ
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> ExpQ) -> Q String -> ExpQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [String] -> String -> IndexUsed -> Q String
    runGit [String
    "rev-parse", String
    "--abbrev-ref", String
    "HEAD"] String
    "UNKNOWN" IndexUsed
    IdxNotUsed

    -- | Return the long git description for the current git commit, or
    -- @UNKNOWN@ if not in a git repository.
    gitDescribe :: ExpQ
    gitDescribe :: ExpQ
    gitDescribe =
      String -> ExpQ
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> ExpQ) -> Q String -> ExpQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [String] -> String -> IndexUsed -> Q String
    runGit [String
    "describe", String
    "--long", String
    "--always"] String
    "UNKNOWN" IndexUsed
    IdxNotUsed

    -- | Return @True@ if there are non-committed files present in the
    -- repository
    gitDirty :: ExpQ
    gitDirty :: ExpQ
    gitDirty = do
      output <- [String] -> String -> IndexUsed -> Q String
    runGit [String
    "status", String
    "--porcelain"] String
    "" IndexUsed
    IdxUsed
      case output of
        String
    "" -> Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    falseName
        String
    _  -> Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    trueName

    -- | Return @True@ if there are non-commited changes to tracked files
    -- present in the repository
    gitDirtyTracked :: ExpQ
    gitDirtyTracked :: ExpQ
    gitDirtyTracked = do
      output <- [String] -> String -> IndexUsed -> Q String
    runGit [String
    "status", String
    "--porcelain",String
    "--untracked-files=no"] String
    "" IndexUsed
    IdxUsed
      case output of
        String
    "" -> Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    falseName
        String
    _  -> Name -> ExpQ
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    trueName

    -- | Return the number of commits in the current head
    gitCommitCount :: ExpQ
    gitCommitCount :: ExpQ
    gitCommitCount =
      String -> ExpQ
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> ExpQ) -> Q String -> ExpQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [String] -> String -> IndexUsed -> Q String
    runGit [String
    "rev-list", String
    "HEAD", String
    "--count"] String
    "UNKNOWN" IndexUsed
    IdxNotUsed

    -- | Return the commit date of the current head
    gitCommitDate :: ExpQ
    gitCommitDate :: ExpQ
    gitCommitDate =
      String -> ExpQ
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> ExpQ) -> Q String -> ExpQ
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [String] -> String -> IndexUsed -> Q String
    runGit [String
    "log", String
    "HEAD", String
    "-1", String
    "--format=%cd"] String
    "UNKNOWN" IndexUsed
    IdxNotUsed