{-|
Module      : KMonad.Args.TH
Description : Template Haskell to use in the CLI
Copyright   : (c) slotThe, 2021
License     : MIT

Maintainer  : soliditsallgood@mailbox.org
Stability   : experimental
Portability : non-portable (TH)

-}
module KMonad.Args.TH (gitHash) where

import KMonad.Prelude

import Control.Monad.Trans.Maybe
import Language.Haskell.TH (Exp, Q, runIO)
import UnliftIO.Directory (findExecutable)
import UnliftIO.Process (readProcessWithExitCode)

-- | Get the git hash of the current commit at compile time.
gitHash :: Q Exp
gitHash :: Q Exp
gitHash = do
  -- This makes use of the `MonadFail` instance for `MaybeT`,
  -- which simply returns `Nothing` on failure.
  Maybe [Char]
hash <- IO (Maybe [Char]) -> Q (Maybe [Char])
forall a. IO a -> Q a
runIO (IO (Maybe [Char]) -> Q (Maybe [Char]))
-> (MaybeT IO [Char] -> IO (Maybe [Char]))
-> MaybeT IO [Char]
-> Q (Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT IO [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Char] -> Q (Maybe [Char]))
-> MaybeT IO [Char] -> Q (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ do
    Just [Char]
git <- IO (Maybe [Char]) -> MaybeT IO (Maybe [Char])
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe [Char]) -> MaybeT IO (Maybe [Char]))
-> IO (Maybe [Char]) -> MaybeT IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
forall (m :: * -> *). MonadIO m => [Char] -> m (Maybe [Char])
findExecutable [Char]
"git"
    (ExitCode
ExitSuccess, [Char]
hash, [Char]
_) <- IO (ExitCode, [Char], [Char])
-> MaybeT IO (ExitCode, [Char], [Char])
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (ExitCode, [Char], [Char])
 -> MaybeT IO (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char])
-> MaybeT IO (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
forall (m :: * -> *).
MonadIO m =>
[Char] -> [[Char]] -> [Char] -> m (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
git [[Char]
"rev-parse", [Char]
"HEAD"] [Char]
""
    [Char] -> MaybeT IO [Char]
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> MaybeT IO [Char]) -> [Char] -> MaybeT IO [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') [Char]
hash
  [| fromString <$> hash |]