[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:44:33 UTC 2010
The following commit has been merged in the master branch:
commit 20642c10ba91ddf6813ee5d0f645fa22686ae026
Author: John Goerzen <jgoerzen at complete.org>
Date: Sat Oct 9 02:52:54 2004 +0100
Rearranged logging stuff
Keywords:
(jgoerzen at complete.org--projects/missingh--head--1.0--patch-61)
diff --git a/ChangeLog b/ChangeLog
index fd95479..a5ad997 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,20 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
#
+2004-10-08 20:52:54 GMT John Goerzen <jgoerzen at complete.org> patch-61
+
+ Summary:
+ Rearranged logging stuff
+ Revision:
+ missingh--head--1.0--patch-61
+
+
+ modified files:
+ ChangeLog libsrc/MissingH/Logging.hs
+ libsrc/MissingH/Logging/Handler/Syslog.hs
+ libsrc/MissingH/Logging/Logger.hs
+
+
2004-10-08 20:49:35 GMT John Goerzen <jgoerzen at complete.org> patch-60
Summary:
diff --git a/libsrc/MissingH/Logging.hs b/libsrc/MissingH/Logging.hs
index e7da1ab..59247e1 100644
--- a/libsrc/MissingH/Logging.hs
+++ b/libsrc/MissingH/Logging.hs
@@ -30,23 +30,7 @@ This module defines basic types used for logging.
module MissingH.Logging(-- * Types
Priority(..),
- LogRecord,
- Logger,
- -- * Logging Messages
- -- ** Basic
- logM,
- -- ** Utility Functions
- -- These functions are wrappers for 'logM' to help
- -- make your job easier.
- debugM, infoM, noticeM, warningM, errorM, criticalM,
- alertM, emergencyM,
- -- * Logger Manipulation
- -- More functions are available in
- -- "MissingH.Logging.Logger".
- -- ** Finding \/ Creating Loggers
- getLogger, getRootLogger, rootLoggerName,
- -- ** Logging to a particular Logger
- logL
+ LogRecord
)
where
@@ -70,199 +54,7 @@ data Priority =
| EMERGENCY -- ^ System is unusable
deriving (Eq, Ord, Show, Read)
-type LogRecord = (Priority, String)
-
----------------------------------------------------------------------------
--- Basic logger types
----------------------------------------------------------------------------
-data HandlerT = forall a. LogHandler a => HandlerT a
-
-data Logger = Logger { level :: Priority,
- handlers :: [HandlerT],
- name :: String}
-
-
-type LogTree = FiniteMap String Logger
-
-{- | This is the base class for the various log handlers. They should
-all adhere to this class. -}
-
-
----------------------------------------------------------------------------
--- Utilities
----------------------------------------------------------------------------
-
--- | The name of the root logger, which is always defined and present
--- on the system.
-rootLoggerName = ""
-
--- | Placeholders created when a new logger must be created.
-placeholder :: Logger
-placeholder = Logger {level = DEBUG, handlers = [], name = ""}
-
----------------------------------------------------------------------------
--- Logger Tree Storage
----------------------------------------------------------------------------
-
--- | The log tree. Initialize it with a default root logger
--- and (FIXME) a logger for MissingH itself.
-
-{-# NOINLINE logTree #-}
-
-logTree :: IORef LogTree
--- note: only kick up tree if handled locally
-logTree =
- unsafePerformIO $ do
- h <- streamHandler stderr DEBUG
- newIORef (unitFM rootLoggerName (Logger
- {level = WARNING,
- name = "",
- handlers = [HandlerT h]}))
-
--- | Given a name, return all components of it, starting from the root.
-componentsOfName :: String -> [String]
-componentsOfName name =
- let joinComp [] _ = []
- joinComp (x:xs) [] = x : joinComp xs x
- joinComp (x:xs) accum =
- let newlevel = accum ++ "." ++ x in
- newlevel : joinComp xs newlevel
- in
- rootLoggerName : joinComp (split "." name) []
-
-createLoggers :: [String] -> IO ()
-createLoggers [] = return ()
-createLoggers (x:xs) =
- do
- lt <- readIORef logTree
- if elemFM x lt
- then createLoggers xs
- else do
- modifyIORef logTree (\a -> addToFM a x (placeholder {name = x}))
- createLoggers xs
-
----------------------------------------------------------------------------
--- Logging With Location
----------------------------------------------------------------------------
-
-{- | Log a message using the given logger at a given priority. -}
-
-logM :: String -- ^ Name of the logger to use
- -> Priority -- ^ Priority of this message
- -> String -- ^ The log text itself
- -> IO ()
+{- | Internal type of log records -}
-logM logname pri msg = do
- l <- getLogger logname
- logL l pri msg
-
----------------------------------------------------------------------------
--- Utility functions
----------------------------------------------------------------------------
-
-{- | Log a message at 'DEBUG' priority -}
-debugM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-debugM s = logM s DEBUG
-
-{- | Log a message at 'INFO' priority -}
-infoM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-infoM s = infoM s INFO
-
-{- | Log a message at 'NOTICE' priority -}
-noticeM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-noticeM s = logM s NOTICE
-
-{- | Log a message at 'WARNING' priority -}
-warningM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-warningM s = logM s WARNING
-
-{- | Log a message at 'ERROR' priority -}
-errorM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-errorM s = logM s ERROR
-
-{- | Log a message at 'CRITICAL' priority -}
-criticalM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-criticalM s = logM s CRITICAL
-
-{- | Log a message at 'ALERT' priority -}
-alertM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-alertM s = logM s ALERT
-
-{- | Log a message at 'EMERGENCY' priority -}
-emergencyM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-emergencyM s = logM s EMERGENCY
-
----------------------------------------------------------------------------
--- Public Logger Interaction Support
----------------------------------------------------------------------------
-
--- | Returns the logger for the given name. If no logger with that name
--- exists, creates new loggers and any necessary parent loggers, with
--- no connected handlers.
-
-getLogger :: String -> IO Logger
-getLogger lname =
- do
- --putStrLn lname
- lt <- readIORef logTree
- --putStrLn (show (keysFM lt))
- case lookupFM lt lname of
- Just x -> return x
- Nothing -> do
- --print "Missed it."
- -- Add it. Then call myself to retrieve it.
- createLoggers (componentsOfName lname)
- --putStrLn "createLoggers done"
- getLogger lname
-
-
--- | Returns the root logger.
-
-getRootLogger :: IO Logger
-getRootLogger = getLogger rootLoggerName
-
--- | Log a message, assuming the current logger's level permits it.
-logL :: Logger -> Priority -> String -> IO ()
-logL l pri msg = handle l (pri, msg)
-
--- | Handle a log request.
-handle :: Logger -> LogRecord -> IO ()
-handle l (pri, msg) =
- if pri >= (level l)
- then do
- sequence_ (handlerActions (handlers l) (pri, msg))
- -- Send it upstairs if we can
- case (name l) of
- "" -> return ()
- x -> do
- parent <- (getLogger . head . drop 1 . reverse . componentsOfName) x
- handle parent (pri, msg)
- else return ()
-
-
--- | Call a handler given a HandlerT.
-callHandler :: LogRecord -> HandlerT -> IO ()
-callHandler lr ht =
- case ht of
- HandlerT x -> MissingH.Logging.Handler.handle x lr
+type LogRecord = (Priority, String)
--- | Generate IO actions for the handlers.
-handlerActions :: [HandlerT] -> LogRecord -> [IO ()]
-handlerActions h lr = map (callHandler lr) h
-
diff --git a/libsrc/MissingH/Logging/Handler/Syslog.hs b/libsrc/MissingH/Logging/Handler/Syslog.hs
index d556cad..eaf7b7d 100644
--- a/libsrc/MissingH/Logging/Handler/Syslog.hs
+++ b/libsrc/MissingH/Logging/Handler/Syslog.hs
@@ -44,7 +44,7 @@ import IO
code_of_pri :: Priority -> Int
code_of_pri p = case p of
- EMERG -> 0
+ EMERGENCY -> 0
ALERT -> 1
CRITICAL -> 2
ERROR -> 3
diff --git a/libsrc/MissingH/Logging/Logger.hs b/libsrc/MissingH/Logging/Logger.hs
index 05f5079..3789ad4 100644
--- a/libsrc/MissingH/Logging/Logger.hs
+++ b/libsrc/MissingH/Logging/Logger.hs
@@ -26,14 +26,24 @@ Written by John Goerzen, jgoerzen\@complete.org
module MissingH.Logging.Logger(-- * Basic Types
Logger,
- -- * Finding Loggers
- getLogger, getRootLogger,
-- * Logging Messages
+ -- ** Basic
+ logM,
+ -- ** Utility Functions
+ -- These functions are wrappers for 'logM' to
+ -- make your job easier.
+ debugM, infoM, noticeM, warningM, errorM,
+ criticalM, alertM, emergencyM,
+ -- * Logger Manipulation
+ -- More functions are available in
+ -- "MissingH.Logging.Logger".
+ -- ** Finding \/ Creating Loggers
+ getLogger, getRootLogger, rootLoggerName,
+ -- ** Logging to a particular Logger
logL,
- -- * Modifying Loggers
+ -- ** Modifying Loggers
addHandler, getLevel, setLevel,
updateGlobalLogger
-
) where
import MissingH.Str
import MissingH.Logging
@@ -46,6 +56,202 @@ import Data.IORef
import Data.List(map)
import Data.FiniteMap
+---------------------------------------------------------------------------
+-- Basic logger types
+---------------------------------------------------------------------------
+data HandlerT = forall a. LogHandler a => HandlerT a
+
+data Logger = Logger { level :: Priority,
+ handlers :: [HandlerT],
+ name :: String}
+
+
+type LogTree = FiniteMap String Logger
+
+{- | This is the base class for the various log handlers. They should
+all adhere to this class. -}
+
+
+---------------------------------------------------------------------------
+-- Utilities
+---------------------------------------------------------------------------
+
+-- | The name of the root logger, which is always defined and present
+-- on the system.
+rootLoggerName = ""
+
+-- | Placeholders created when a new logger must be created.
+placeholder :: Logger
+placeholder = Logger {level = DEBUG, handlers = [], name = ""}
+
+---------------------------------------------------------------------------
+-- Logger Tree Storage
+---------------------------------------------------------------------------
+
+-- | The log tree. Initialize it with a default root logger
+-- and (FIXME) a logger for MissingH itself.
+
+{-# NOINLINE logTree #-}
+
+logTree :: IORef LogTree
+-- note: only kick up tree if handled locally
+logTree =
+ unsafePerformIO $ do
+ h <- streamHandler stderr DEBUG
+ newIORef (unitFM rootLoggerName (Logger
+ {level = WARNING,
+ name = "",
+ handlers = [HandlerT h]}))
+
+-- | Given a name, return all components of it, starting from the root.
+componentsOfName :: String -> [String]
+componentsOfName name =
+ let joinComp [] _ = []
+ joinComp (x:xs) [] = x : joinComp xs x
+ joinComp (x:xs) accum =
+ let newlevel = accum ++ "." ++ x in
+ newlevel : joinComp xs newlevel
+ in
+ rootLoggerName : joinComp (split "." name) []
+
+createLoggers :: [String] -> IO ()
+createLoggers [] = return ()
+createLoggers (x:xs) =
+ do
+ lt <- readIORef logTree
+ if elemFM x lt
+ then createLoggers xs
+ else do
+ modifyIORef logTree (\a -> addToFM a x (placeholder {name = x}))
+ createLoggers xs
+
+---------------------------------------------------------------------------
+-- Logging With Location
+---------------------------------------------------------------------------
+
+{- | Log a message using the given logger at a given priority. -}
+
+logM :: String -- ^ Name of the logger to use
+ -> Priority -- ^ Priority of this message
+ -> String -- ^ The log text itself
+ -> IO ()
+
+logM logname pri msg = do
+ l <- getLogger logname
+ logL l pri msg
+
+---------------------------------------------------------------------------
+-- Utility functions
+---------------------------------------------------------------------------
+
+{- | Log a message at 'DEBUG' priority -}
+debugM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+debugM s = logM s DEBUG
+
+{- | Log a message at 'INFO' priority -}
+infoM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+infoM s = logM s INFO
+
+{- | Log a message at 'NOTICE' priority -}
+noticeM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+noticeM s = logM s NOTICE
+
+{- | Log a message at 'WARNING' priority -}
+warningM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+warningM s = logM s WARNING
+
+{- | Log a message at 'ERROR' priority -}
+errorM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+errorM s = logM s ERROR
+
+{- | Log a message at 'CRITICAL' priority -}
+criticalM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+criticalM s = logM s CRITICAL
+
+{- | Log a message at 'ALERT' priority -}
+alertM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+alertM s = logM s ALERT
+
+{- | Log a message at 'EMERGENCY' priority -}
+emergencyM :: String -- ^ Logger name
+ -> String -- ^ Log message
+ -> IO ()
+emergencyM s = logM s EMERGENCY
+
+---------------------------------------------------------------------------
+-- Public Logger Interaction Support
+---------------------------------------------------------------------------
+
+-- | Returns the logger for the given name. If no logger with that name
+-- exists, creates new loggers and any necessary parent loggers, with
+-- no connected handlers.
+
+getLogger :: String -> IO Logger
+getLogger lname =
+ do
+ --putStrLn lname
+ lt <- readIORef logTree
+ --putStrLn (show (keysFM lt))
+ case lookupFM lt lname of
+ Just x -> return x
+ Nothing -> do
+ --print "Missed it."
+ -- Add it. Then call myself to retrieve it.
+ createLoggers (componentsOfName lname)
+ --putStrLn "createLoggers done"
+ getLogger lname
+
+
+-- | Returns the root logger.
+
+getRootLogger :: IO Logger
+getRootLogger = getLogger rootLoggerName
+
+-- | Log a message, assuming the current logger's level permits it.
+logL :: Logger -> Priority -> String -> IO ()
+logL l pri msg = handle l (pri, msg)
+
+-- | Handle a log request.
+handle :: Logger -> LogRecord -> IO ()
+handle l (pri, msg) =
+ if pri >= (level l)
+ then do
+ sequence_ (handlerActions (handlers l) (pri, msg))
+ -- Send it upstairs if we can
+ case (name l) of
+ "" -> return ()
+ x -> do
+ parent <- (getLogger . head . drop 1 . reverse . componentsOfName) x
+ handle parent (pri, msg)
+ else return ()
+
+
+-- | Call a handler given a HandlerT.
+callHandler :: LogRecord -> HandlerT -> IO ()
+callHandler lr ht =
+ case ht of
+ HandlerT x -> MissingH.Logging.Handler.handle x lr
+
+-- | Generate IO actions for the handlers.
+handlerActions :: [HandlerT] -> LogRecord -> [IO ()]
+handlerActions h lr = map (callHandler lr) h
+
+
+
-- | Add handler to 'Logger'. Returns a new 'Logger'.
addHandler :: LogHandler a => Logger -> a -> Logger
@@ -68,3 +274,4 @@ setLevel l p = l{level = p}
updateGlobalLogger :: Logger -> IO ()
updateGlobalLogger l = modifyIORef logTree (\a -> addToFM a (name l) l)
+
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list