[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 fe8a0ee226450c5df005db960d79ec4facace5c8
Author: John Goerzen <jgoerzen at complete.org>
Date:   Thu Dec 9 23:15:01 2004 +0100

    Added some new logging code
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-55)

diff --git a/ChangeLog b/ChangeLog
index f67f157..c896e2e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,19 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-09 16:15:01 GMT	John Goerzen <jgoerzen at complete.org>	patch-55
+
+    Summary:
+      Added some new logging code
+    Revision:
+      missingh--head--0.7--patch-55
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/Email/Parser.hs
+     libsrc/MissingH/Logging/Logger.hs
+
+
 2004-12-09 15:12:29 GMT	John Goerzen <jgoerzen at complete.org>	patch-54
 
     Summary:
diff --git a/libsrc/MissingH/Email/Parser.hs b/libsrc/MissingH/Email/Parser.hs
index 205b5fd..c5c5472 100644
--- a/libsrc/MissingH/Email/Parser.hs
+++ b/libsrc/MissingH/Email/Parser.hs
@@ -31,7 +31,7 @@ Parses an e-mail message
 Written by John Goerzen, jgoerzen\@complete.org
 -}
 
-module MissingH.Email.Parser(mailParser)
+module MissingH.Email.Parser(mailParser, flattenMessage)
 where
 
 import MissingH.Hsemail.Rfc2234(crlf)
@@ -70,3 +70,16 @@ mailParser s = do
                                      rawLines = lines (snd p)}
                return $ digestMessage raw
 
+{- | Given a 'MissingH.Wash.Mail.Message.Message' object, \"flatten\"
+it into a simple, non-hierarchical list of its component single parts.
+
+Data associated with a multipart will be lost, but each single child component
+of the multipart will be preserved.
+-}
+flattenMessage :: MissingH.Wash.Mail.Message.Message -> 
+                  [MissingH.Wash.Mail.Message.Message]
+flattenMessage x =
+    case x of
+       y@(MissingH.Wash.Mail.Message.Singlepart {}) -> [y]
+       y@(MissingH.Wash.Mail.Message.Multipart {}) ->
+           concatMap flattenMessage (MissingH.Wash.Mail.Message.getParts y)
diff --git a/libsrc/MissingH/Logging/Logger.hs b/libsrc/MissingH/Logging/Logger.hs
index 6caa507..5266186 100644
--- a/libsrc/MissingH/Logging/Logger.hs
+++ b/libsrc/MissingH/Logging/Logger.hs
@@ -141,6 +141,7 @@ module MissingH.Logging.Logger(
                                -- make your job easier.
                                debugM, infoM, noticeM, warningM, errorM,
                                criticalM, alertM, emergencyM,
+                               traplogging,
                                -- ** Logging to a particular Logger by object
                                logL,
                                -- * Logger Manipulation
@@ -182,7 +183,7 @@ import System.IO.Unsafe
 import Data.IORef
 import Data.List(map)
 import Data.FiniteMap
-
+import qualified Control.Exception
 ---------------------------------------------------------------------------
 -- Basic logger types
 ---------------------------------------------------------------------------
@@ -429,3 +430,25 @@ updateGlobalLogger ln func =
     do 
     l <- getLogger ln
     saveGlobalLogger (func l)
+
+{- | Traps exceptions that may occur, logging them, then passing them on.
+
+Takes a logger name, priority, leading description text (you can set it to
+@\"\"@ if you don't want any), and action to run.
+-}
+
+traplogging :: String                   -- Logger name
+            -> Priority                 -- Logging priority
+            -> String                   -- Descriptive text to prepend to logged messages
+            -> IO a                     -- Action to run
+            -> IO a                     -- Return value
+traplogging logger priority desc action =
+    let realdesc = case desc of
+                             "" -> ""
+                             x -> x ++ ": "
+        handler e = do
+                    logM logger priority (realdesc ++ (show e))
+                    Control.Exception.throw e             -- Re-raise it
+        in
+        Control.Exception.catch action handler
+    

-- 
haskell-testpack