-- |
-- Module      : Language.Haskell.TH.Lib.Extra
-- Copyright   : 2013 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides extra helper functions
-- complementing "Language.Haskell.TH.Lib"
module Language.Haskell.TH.Lib.Extra (
  -- * Extra template functions
  -- $extraTemplateFunctions
  integralE, simpleValD, maybeD,

  -- * Pretty printing for 'Q' monad
  -- $prettyPrint
  pprQ,

  -- * Functions to print message or errors when compile time
  -- $compileMessage
  reportMessage, reportWarning, reportError,
  ) where

import System.IO (hPutStrLn, stderr)
import System.Environment (getEnvironment)

import Language.Haskell.TH
  (Ppr, ppr, Q, runQ, runIO,
   Name, Dec, sigD, valD, TypeQ, varP, normalB,
   ExpQ, litE, integerL)
import Language.Haskell.TH.PprLib (Doc)
import Language.Haskell.TH.Syntax (Quasi, qReport)

{- $extraTemplateFunctions
Extra functions to generate haskell templates.
-}

-- | Integer literal template from 'Integral' types.
integralE :: Integral a => a -> ExpQ
integralE =  litE . integerL . toInteger

-- | Generate declaration template from name, type and expression.
simpleValD :: Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD var typ expr =  do
  sig <- sigD var typ
  val <- valD (varP var) (normalB expr) []
  return [sig, val]

-- | May generate declaration template.
maybeD :: (a -> Q [Dec]) -> Maybe a -> Q [Dec]
maybeD =  maybe (return [])

{- $prettyPrint
Pretty printing for haskell templates.
-}

-- | Helper function for pretty printing 'Q' Monad.
pprQ :: (Functor m, Quasi m, Ppr a) => Q a -> m Doc
pprQ =  fmap ppr . runQ

{- $compileMessage
Functions to display or to raise compile messages from codes
which generating haskell templates.

Only messages directly generated by 'Q' monad report actions
are handled by ghc loggers.

> -- Handled by ghc logger
> qReport False "Foo"

> -- Not handled by ghc logger
> runIO . runQ $ qReport False "Foo"
 -}

-- | Print compile message from TH code.
--   Only display when TH_EXTRA_MESSAGE_OUTPUT environment variable is set.
--   When variable value string is 'as_warn' or 'as_warning' and
--   using 'Q' monad action, Output is put into ghc logger as warning.
--   Other cases are normal standard error output.
reportMessage :: Quasi m => String -> m ()
reportMessage s = runQ . runIO $ do
  let lookupEnv n = lookup n `fmap` getEnvironment  {- for base-4.5 -}
  mayOut <- lookupEnv "TH_EXTRA_MESSAGE_OUTPUT"
  case mayOut of
    Just out
      | out `elem` ["as_warn", "as_warning"]  ->  qReport False s
      | otherwise                             ->  hPutStrLn stderr s
    Nothing                                   ->  return ()

-- | Print compile warnings from TH code.
reportWarning :: String -> Q ()
reportWarning =  qReport False

-- | Print compile errors from TH code.
reportError :: String -> Q ()
reportError =  qReport True