src/Logging.hs

   1 module Logging (
   2   init_logging,
   3   log_debug,
   4   log_error,
   5   log_info,
   6   log_warning )
   7 where
   8
   9 import System.IO ( hPutStr, stderr, stdout )
  10 import System.Log ( LogRecord )
  11 import System.Log.Formatter ( LogFormatter )
  12 import System.Log.Logger (
  13   Priority ( DEBUG, ERROR, INFO, WARNING ),
  14   debugM,
  15   errorM,
  16   infoM,
  17   rootLoggerName,
  18   setHandlers,
  19   setLevel,
  20   updateGlobalLogger,
  21   warningM )
  22 import System.Log.Handler.Simple (
  23   GenericHandler(..),
  24   streamHandler )
  25
  26 import Terminal ( hPutBlueStr, hPutRedStr )
  27
  28 log_debug :: String -> IO ()
  29 log_debug = debugM rootLoggerName
  30
  31 log_error :: String -> IO ()
  32 log_error = errorM rootLoggerName
  33
  34 log_info :: String -> IO ()
  35 log_info = infoM rootLoggerName
  36
  37 log_warning :: String -> IO ()
  38 log_warning = warningM rootLoggerName
  39
  40 -- | Debug messages output to the console don't get a prefix, since
  41 --   they're used to dump the network chatter.
  42 console_formatter :: LogRecord -> IO String
  43 console_formatter (DEBUG, msg) = return $ msg ++ "\n"
  44 console_formatter (prio, msg) = return $ (show prio) ++ ": " ++ msg ++ "\n"
  45
  46
  47 warn_formatter :: LogFormatter a
  48 warn_formatter  _ x@(WARNING, _) _ = console_formatter x
  49 warn_formatter  _ x@(ERROR, _) _ = console_formatter x
  50 warn_formatter  _ _ _ = return ""
  51
  52 info_formatter :: LogFormatter a
  53 info_formatter  _ x@(INFO, _) _ = console_formatter x
  54 info_formatter  _ _ _ = return ""
  55
  56 debug_formatter :: LogFormatter a
  57 debug_formatter  _ x@(DEBUG, _) _ = console_formatter x
  58 debug_formatter  _ _ _ = return ""
  59
  60
  61 init_logging :: IO ()
  62 init_logging = do
  63   -- Set the root logger to DEBUG level so that it will *attempt* to
  64   -- process every message.
  65   updateGlobalLogger rootLoggerName (setLevel DEBUG)
  66
  67   stdout_handler <- streamHandler stdout DEBUG
  68   stderr_handler <- streamHandler stderr WARNING
  69
  70   let debug_handler = stdout_handler { formatter = debug_formatter,
  71                                        writeFunc = hPutStr }
  72
  73   let info_handler = stdout_handler { formatter = info_formatter,
  74                                       priority = INFO,
  75                                       writeFunc = hPutBlueStr }
  76
  77   -- This also catches ERRORs.
  78   let warn_handler = stderr_handler { formatter = warn_formatter,
  79                                       priority = WARNING,
  80                                       writeFunc = hPutRedStr }
  81
  82   -- Set debug, info, and warn handlers for the root log.
  83   updateGlobalLogger
  84     rootLoggerName
  85     (setHandlers [debug_handler, info_handler, warn_handler])