-- | This module provides a function that generates hslogger functions
-- automatically using Template Haskell.
module System.Log.Logger.TH (deriveLoggers) where

import qualified Language.Haskell.TH as TH

import qualified System.Log.Logger as HSL

-- | Generate hslogger functions for given priorities.
--
-- Example usage:
--
-- > module Foo.Bar ( ... ) where
-- >
-- > import System.Log.Logger.TH (deriveLoggers)
-- > import qualified System.Log.Logger as HSL
-- >
-- > $(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO])
--
-- Used this way, @deriveLoggers@ would generate the following functions:
--
-- > info :: String -> IO ()
-- > info s = HSL.infoM "Foo.Bar" ((++) "Foo.Bar: " s)
-- >
-- > debug :: String -> IO ()
-- > debug s = HSL.debugM "Foo.Bar" ((++) "Foo.Bar: " s)
--
-- The other hslogger priorities follow the same pattern.
--
-- So
--
-- > info "hi there"
--
-- would generate the INFO-level log event
--
-- > Foo.Bar: hi there
--
-- Note: "System.Log.Logger" must be imported qualified, and the qualifier must
-- match the qualifier given to @deriveLoggers@.
--
deriveLoggers
  :: String          -- ^ Must match qualifier on import of "System.Log.Logger".
  -> [HSL.Priority]  -- ^ List of priorities for which to generate logging functions.
  -> TH.Q [TH.Dec]
deriveLoggers qualifier priorities =
    fmap TH.loc_module TH.location >>= \moduleName ->
      fmap concat (mapM (deriveLogger qualifier moduleName) priorities)

-- ----------------------------------------

deriveLogger :: String -> String -> HSL.Priority -> TH.Q [TH.Dec]
deriveLogger qualifier moduleName priority = code
  where
    code = do
        sig  <- TH.sigD th_f [t| String -> IO () |]
        body <- TH.funD th_f
                  [ TH.clause [TH.varP th_s]
                    (TH.normalB
                      (TH.appE
                        (TH.appE
                          (TH.varE th_h)
                          (TH.stringE moduleName)
                        )
                        (TH.appE
                          (TH.appE
                            (TH.varE '(++))
                            (TH.litE (TH.stringL (moduleName ++ ": ")))
                          )
                          (TH.varE th_s)
                        )
                      )
                    )
                    []
                  ]
        return [sig, body]
      where
        th_f = TH.mkName functionName
        th_h = TH.mkName (concat [qualifier, ".", functionName, "M"])
        th_s = TH.mkName "s"
        functionName =
          case priority of
            HSL.DEBUG     -> "debug"
            HSL.INFO      -> "info"
            HSL.NOTICE    -> "notice"
            HSL.WARNING   -> "warning"
            HSL.ERROR     -> "error"
            HSL.CRITICAL  -> "critical"
            HSL.ALERT     -> "alert"
            HSL.EMERGENCY -> "emergency"