+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])