[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:32 UTC 2010
The following commit has been merged in the master branch:
commit 944f21000302f50d544e8dda4e309dcb9a3887c2
Author: John Goerzen <jgoerzen at complete.org>
Date: Sat Oct 9 02:49:35 2004 +0100
Checkpointing -- need to rearrange some things.
Keywords:
(jgoerzen at complete.org--projects/missingh--head--1.0--patch-60)
diff --git a/ChangeLog b/ChangeLog
index 9763fc1..fd95479 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,19 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
#
+2004-10-08 20:49:35 GMT John Goerzen <jgoerzen at complete.org> patch-60
+
+ Summary:
+ Checkpointing -- need to rearrange some things.
+ Revision:
+ missingh--head--1.0--patch-60
+
+
+ modified files:
+ ChangeLog libsrc/MissingH/Logging.hs
+ libsrc/MissingH/Logging/Logger.hs
+
+
2004-10-08 20:19:18 GMT John Goerzen <jgoerzen at complete.org> patch-59
Summary:
diff --git a/libsrc/MissingH/Logging.hs b/libsrc/MissingH/Logging.hs
index 2d2307b..e7da1ab 100644
--- a/libsrc/MissingH/Logging.hs
+++ b/libsrc/MissingH/Logging.hs
@@ -16,7 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
-{- | Basic logging types
+{- | Logging Infrastructure for Haskell
Written by John Goerzen, jgoerzen\@complete.org
@@ -26,8 +26,28 @@ This module defines basic types used for logging.
-}
-module MissingH.Logging(Priority(..),
- LogRecord)
+
+
+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
+)
where
@@ -47,8 +67,202 @@ data Priority =
| ERROR -- ^ General Errors
| CRITICAL -- ^ Severe situations
| ALERT -- ^ Take immediate action
- | EMERG -- ^ System is unusable
+ | 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 ()
+
+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
+
+-- | Generate IO actions for the handlers.
+handlerActions :: [HandlerT] -> LogRecord -> [IO ()]
+handlerActions h lr = map (callHandler lr) h
+
diff --git a/libsrc/MissingH/Logging/Logger.hs b/libsrc/MissingH/Logging/Logger.hs
index df79f93..05f5079 100644
--- a/libsrc/MissingH/Logging/Logger.hs
+++ b/libsrc/MissingH/Logging/Logger.hs
@@ -29,7 +29,7 @@ module MissingH.Logging.Logger(-- * Basic Types
-- * Finding Loggers
getLogger, getRootLogger,
-- * Logging Messages
- logM,
+ logL,
-- * Modifying Loggers
addHandler, getLevel, setLevel,
updateGlobalLogger
@@ -46,125 +46,7 @@ import Data.IORef
import Data.List(map)
import Data.FiniteMap
------------------------------------------------------------------------
--- Basic types
-
-data HandlerT = forall a. LogHandler a => HandlerT a
-
-data Logger = Logger { level :: Priority,
- handlers :: [HandlerT],
- name :: String}
-
-
-type LogTree = FiniteMap String Logger
-
------------------------------------------------------------------------
--- Module shortcuts
-
-rootlogger = ""
-
------------------------------------------------------------------------
--- Utilities
-
--- | 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 rootlogger (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
- rootlogger : 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
-
-
--- | 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 ""
-
--- | Log a message, assuming the current logger's level permits it.
-logM :: Logger -> Priority -> String -> IO ()
-logM 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
addHandler l h = l{handlers = (HandlerT h) : (handlers l)}
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list