-- | This module provides functions that generate hslogger functions 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 a list of 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:
--
-- > infoM :: String -> IO ()
-- > infoM s = HSL.infoM "Foo.Bar" ((++) "Foo.Bar: " s)
-- >
-- > debugM :: String -> IO ()
-- > debugM s = HSL.debugM "Foo.Bar" ((++) "Foo.Bar: " s)
--
-- The other hslogger priorities follow the same pattern.
--
-- So
--
-- > infoM "hi there"
--
-- would generate the INFO-level log event
--
-- > Foo.Bar: hi there
--
-- Notes:
--
--   * "System.Log.Logger" must be imported qualified, and the qualifier must
--   match the qualifier given to @deriveLoggers@.
--
--   * Don't forget to enable Template Haskell preprocessing: specify the
--   pragma @LANGUAGE TemplateHaskell@ at the top of your source file or
--   @extensions: TemplateHaskell@ in your cabal file, etc.
--
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.stringE prefix)
                            )
                            (TH.varE th_s)
                          )
                        )
                      )
                      []
                  ]
        return [sig, body]
      where
        th_s = TH.mkName "s"
        th_f = TH.mkName functionName
        th_h = TH.mkName (qualifier ++ "." ++ functionName)
        prefix = moduleName ++ ": "
        functionName =
          case priority of
            HSL.DEBUG     -> "debugM"
            HSL.INFO      -> "infoM"
            HSL.NOTICE    -> "noticeM"
            HSL.WARNING   -> "warningM"
            HSL.ERROR     -> "errorM"
            HSL.CRITICAL  -> "criticalM"
            HSL.ALERT     -> "alertM"
            HSL.EMERGENCY -> "emergencyM"