{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Version.TH
-- Copyright   :  (c) Masahiro Sakai 2015
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module ToySolver.Version.TH
  ( gitHashQ
  , compilationTimeQ
  ) where

import Control.Exception
import Control.Monad
import Data.Time
import System.Process
import Language.Haskell.TH

getGitHash :: IO (Maybe String)
getGitHash :: IO (Maybe String)
getGitHash =
  (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')) (String -> [String] -> String -> IO String
readProcess String
"git" [String
"rev-parse", String
"--short", String
"HEAD"] String
"")
  IO (Maybe String)
-> (SomeException -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_::SomeException) -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

gitHashQ :: ExpQ
gitHashQ :: ExpQ
gitHashQ = do
  Maybe String
m <- IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO IO (Maybe String)
getGitHash
  case Maybe String
m of
    Maybe String
Nothing -> [| Nothing |]
    Just String
s -> [| Just |] ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
s)

compilationTimeQ :: ExpQ
compilationTimeQ :: ExpQ
compilationTimeQ = do
  UTCTime
tm <- IO UTCTime -> Q UTCTime
forall a. IO a -> Q a
runIO IO UTCTime
getCurrentTime
  [| read $(Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
tm))) :: UTCTime |]