[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

The following commit has been merged in the master branch:
commit ca46331f3c709776f83fd625ff27d3dadf87d32e
Author: John Goerzen <jgoerzen at complete.org>
Date:   Fri Oct 8 01:54:47 2004 +0100

    Checkpointing logging work
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--1.0--patch-44)

diff --git a/ChangeLog b/ChangeLog
index 3386d08..7ddd327 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,19 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
 #
 
+2004-10-07 19:54:47 GMT	John Goerzen <jgoerzen at complete.org>	patch-44
+
+    Summary:
+      Checkpointing logging work
+    Revision:
+      missingh--head--1.0--patch-44
+
+
+    modified files:
+     ChangeLog Makefile libsrc/MissingH/Logging.hs
+     libsrc/MissingH/Logging/Handler.hs
+
+
 2004-10-07 16:12:35 GMT	John Goerzen <jgoerzen at complete.org>	patch-43
 
     Summary:
diff --git a/Makefile b/Makefile
index e5778c2..e04e09d 100644
--- a/Makefile
+++ b/Makefile
@@ -51,5 +51,8 @@ test-ghc6: testsrc/runtests
 test-hugs:
 	runhugs -P:$(PWD)/libsrc:$(PWD)/testsrc testsrc/runtests.hs
 
+interact-hugs:
+	hugs -P:$(PWD)/libsrc
+
 test: test-ghc6 test-hugs
 
diff --git a/libsrc/MissingH/Logging.hs b/libsrc/MissingH/Logging.hs
index b96fc22..9d8fbc2 100644
--- a/libsrc/MissingH/Logging.hs
+++ b/libsrc/MissingH/Logging.hs
@@ -33,17 +33,19 @@ Users can filter log messages based on priorities.
 
 These have their roots on the traditional syslog system.  The standard
 definitions are given below, but you are free to interpret them however you
-like.  They are listed here in descending importance order.
+like.  They are listed here in ascending importance order.
 -}
 
-data Priority = EMERG                   -- ^ System is unusable
-              | ALERT                   -- ^ Take immediate action
-              | CRITICAL                -- ^ Severe situations
-              | ERROR                   -- ^ General Errors
-              | WARNING                 -- ^ General Warnings
-              | NOTICE                  -- ^ Normal runtime conditions
-              | INFO                    -- ^ Information
-              | DEBUG                   -- ^ Debug messages
+data Priority = 
+            DEBUG                   -- ^ Debug messages
+          | INFO                    -- ^ Information
+          | NOTICE                  -- ^ Normal runtime conditions
+          | WARNING                 -- ^ General Warnings
+          | ERROR                   -- ^ General Errors
+          | CRITICAL                -- ^ Severe situations
+          | ALERT                   -- ^ Take immediate action
+          | EMERG                   -- ^ System is unusable
+                    deriving (Eq, Ord, Show, Read)
 
 type LogRecord = (Priority, String)
 
diff --git a/libsrc/MissingH/Logging/Handler.hs b/libsrc/MissingH/Logging/Handler.hs
index fc6d4cf..c67a8de 100644
--- a/libsrc/MissingH/Logging/Handler.hs
+++ b/libsrc/MissingH/Logging/Handler.hs
@@ -24,7 +24,7 @@ n-}
 module MissingH.Logging.Handler(-- * Basic Types
                                 LogHandler(..),
                                 -- * Simple Handlers
-                                newStreamHandler, TStreamH
+                                streamHandler, fileHandler
                                ) where
 import MissingH.Logging
 import IO
@@ -42,6 +42,11 @@ class LogHandler a where
                    -- | Logs an event if it meets the requirements
                    -- given by the most recent call to 'setLevel'.
                    handle :: a -> LogRecord -> IO ()
+
+                   handle h (pri, msg) = 
+                       if pri >= (getLevel h)
+                          then emit h (pri, msg)
+                          else return ()
                    -- | Forces an event to be logged regardless of
                    -- the configured level.
                    emit :: a -> LogRecord -> IO ()
@@ -50,18 +55,36 @@ class LogHandler a where
                    close :: a -> IO ()
 
 
--- ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
--- Stream handler
--- ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+data GenericHandler a = GenericHandler {priority :: Priority,
+                                        privData :: a,
+                                        writeFunc :: a -> String -> IO (),
+                                        closeFunc :: a -> IO () }
+
+instance LogHandler (GenericHandler a) where
+    setLevel sh p = sh{priority = p}
+    getLevel sh = priority sh
+    emit sh lr = (writeFunc sh) (privData sh) (snd lr)
+    close sh = (closeFunc sh) (privData sh)
+
+{- | Create a stream log handler.  Log messages sent to this handler will
+   be sent to the stream used initially.  Note that the 'close' method
+   will have no effect on stream handlers; it does not actually close
+   the underlying stream.  -}
 
-data TStreamH = TStreamH (Handle, Priority)
+streamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
+streamHandler h pri = 
+    return (GenericHandler {priority = pri,
+                            privData = h,
+                            writeFunc = hPutStrLn,
+                            closeFunc = \x -> return ()})
 
-instance LogHandler TStreamH where
-    setLevel (TStreamH (h, pri)) newpri = TStreamH (h, newpri)
-    getLevel (TStreamH (h, pri)) = pri
-    handle (TStreamH (h, pri)) rec = return ()
-    emit (TStreamH(h, pri)) rec = return ()
-    close _ = return ()
+{- | Create a file log handler.  Log messages sent to this handler
+   will be sent to the filename specified, which will be opened
+   in Append mode.  Calling close on the handler will close the file.
+   -}
 
-newStreamHandler :: Handle -> Priority -> TStreamH
-newStreamHandler h pri = TStreamH (h, pri)
+fileHandler :: FilePath -> Priority -> IO (GenericHandler Handle)
+fileHandler fp pri = do
+                     h <- openFile fp AppendMode
+                     sh <- streamHandler h pri
+                     return (sh{closeFunc = hClose})

-- 
haskell-testpack