module Logging (
  init_logging,
  log_debug,
  log_error,
  log_info,
  log_warning )
where

import System.IO ( hPutStr, stderr, stdout )
import System.Log ( LogRecord )
import System.Log.Formatter ( LogFormatter )
import System.Log.Logger (
  Priority ( DEBUG, ERROR, INFO, WARNING ),
  debugM,
  errorM,
  infoM,
  rootLoggerName,
  setHandlers,
  setLevel,
  updateGlobalLogger,
  warningM )
import System.Log.Handler.Simple (
  GenericHandler(..),
  streamHandler )

import Terminal ( hPutBlueStr, hPutRedStr )

log_debug :: String -> IO ()
log_debug = debugM rootLoggerName

log_error :: String -> IO ()
log_error = errorM rootLoggerName

log_info :: String -> IO ()
log_info = infoM rootLoggerName

log_warning :: String -> IO ()
log_warning = warningM rootLoggerName

-- | Debug messages output to the console don't get a prefix, since
--   they're used to dump the network chatter.
console_formatter :: LogRecord -> IO String
console_formatter (DEBUG, msg) = return $ msg ++ "\n"
console_formatter (prio, msg) = return $ (show prio) ++ ": " ++ msg ++ "\n"


warn_formatter :: LogFormatter a
warn_formatter  _ x@(WARNING, _) _ = console_formatter x
warn_formatter  _ x@(ERROR, _) _ = console_formatter x
warn_formatter  _ _ _ = return ""

info_formatter :: LogFormatter a
info_formatter  _ x@(INFO, _) _ = console_formatter x
info_formatter  _ _ _ = return ""

debug_formatter :: LogFormatter a
debug_formatter  _ x@(DEBUG, _) _ = console_formatter x
debug_formatter  _ _ _ = return ""


init_logging :: IO ()
init_logging = do
  -- Set the root logger to DEBUG level so that it will *attempt* to
  -- process every message.
  updateGlobalLogger rootLoggerName (setLevel DEBUG)

  stdout_handler <- streamHandler stdout DEBUG
  stderr_handler <- streamHandler stderr WARNING

  let debug_handler = stdout_handler { formatter = debug_formatter,
                                       writeFunc = hPutStr }

  let info_handler = stdout_handler { formatter = info_formatter,
                                      priority = INFO,
                                      writeFunc = hPutBlueStr }

  -- This also catches ERRORs.
  let warn_handler = stderr_handler { formatter = warn_formatter,
                                      priority = WARNING,
                                      writeFunc = hPutRedStr }

  -- Set debug, info, and warn handlers for the root log.
  updateGlobalLogger
    rootLoggerName
    (setHandlers [debug_handler, info_handler, warn_handler])