logging 1.1.0 → 1.2.0
raw patch · 3 files changed
+157/−16 lines, 3 filesdep +pcre-light
Dependencies added: pcre-light
Files
- Control/Logging.hs +138/−12
- logging.cabal +6/−2
- test/main.hs +13/−2
Control/Logging.hs view
@@ -12,29 +12,51 @@ module Control.Logging ( log , log'+ , logS+ , logS' , warn , warn'+ , warnS+ , warnS' , debug , debug'+ , debugS+ , debugS' , errorL , errorL'+ , errorSL+ , errorSL' , traceL , traceL'+ , traceSL+ , traceSL' , traceShowL , traceShowL'+ , traceShowSL+ , traceShowSL' , timedLog , timedLog'+ , timedLogS+ , timedLogS' , timedLogEnd , timedLogEnd'+ , timedLogEndS+ , timedLogEndS' , timedDebug , timedDebug'+ , timedDebugS+ , timedDebugS' , timedDebugEnd , timedDebugEnd'+ , timedDebugEndS+ , timedDebugEndS' , withStdoutLogging , withStderrLogging , flushLog+ , loggingLogger , setDebugLevel , setLogFormat+ , setDebugSourceRegexp ) where import Control.Exception.Lifted@@ -44,14 +66,17 @@ import Control.Monad.Trans.Control import Data.AffineSpace import Data.IORef+import Data.Maybe (isJust) import Data.Monoid import Data.Text as T+import Data.Text.Encoding as T import Data.Thyme import Debug.Trace import Prelude hiding (log) import System.IO.Unsafe import System.Locale import System.Log.FastLogger+import Text.Regex.PCRE.Light logLevel :: IORef LogLevel {-# NOINLINE logLevel #-}@@ -75,19 +100,43 @@ setLogFormat :: String -> IO () setLogFormat = atomicWriteIORef logFormat -logger :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> IO ()-logger _loc !src !lvl str = do+debugSourceRegexp :: IORef (Maybe Regex)+{-# NOINLINE debugSourceRegexp #-}+debugSourceRegexp = unsafePerformIO $ newIORef Nothing++-- | When printing 'LevelDebug' messages, only display those matching the+-- given regexp applied to the Source parameter. Calls to 'debug' without a+-- source parameter are regarded as having a source of @""@.+setDebugSourceRegexp :: String -> IO ()+setDebugSourceRegexp =+ atomicWriteIORef debugSourceRegexp+ . Just+ . flip compile []+ . encodeUtf8+ . T.pack++-- | This function is used to implement 'monadLoggerLog' for the IO instance.+-- You may reuse it if you wish, or it can be passed as an argument to+-- 'runLoggingT' -- in which case you must remember to call 'flushLog'+-- before the program exits.+loggingLogger :: ToLogStr msg => Loc -> LogSource -> LogLevel -> msg -> IO ()+loggingLogger _loc !src !lvl str = do maxLvl <- readIORef logLevel when (lvl >= maxLvl) $ do- now <- getCurrentTime- fmt <- readIORef logFormat- let stamp = formatTime defaultTimeLocale fmt now- set <- readIORef logSet- pushLogStr set- $ toLogStr (stamp ++ " " ++ renderLevel lvl- ++ " " ++ renderSource src)- <> toLogStr str- <> toLogStr (pack "\n")+ mre <- readIORef debugSourceRegexp+ let willLog = case mre of+ Nothing -> True+ Just re -> isJust (match re (encodeUtf8 src) [])+ when willLog $ do+ now <- getCurrentTime+ fmt <- readIORef logFormat+ let stamp = formatTime defaultTimeLocale fmt now+ set <- readIORef logSet+ pushLogStr set+ $ toLogStr (stamp ++ " " ++ renderLevel lvl+ ++ " " ++ renderSource src)+ <> toLogStr str+ <> toLogStr (pack "\n") where renderSource :: Text -> String renderSource txt@@ -117,13 +166,16 @@ atomicWriteIORef logSet set f `finally` flushLog +-- | Flush all collected logging messages. This is automatically called by+-- 'withStdoutLogging' and 'withStderrLogging' when those blocks are exited+-- by whatever means. flushLog :: MonadIO m => m () flushLog = liftIO $ do set <- readIORef logSet flushLogStr set instance MonadLogger IO where- monadLoggerLog = logger+ monadLoggerLog = loggingLogger -- | Synonym for 'Control.Monad.Logger.logInfoN'. This module provides a -- 'MonadLogger' instance for IO, so this function can be used directly in@@ -134,23 +186,41 @@ log :: MonadLogger m => Text -> m () log = logInfoN +logS :: MonadLogger m => Text -> Text -> m ()+logS = logInfoNS+ -- | The apostrophe varients of the logging functions flush the log after each -- message. log' :: (MonadLogger m, MonadIO m) => Text -> m () log' msg = log msg >> flushLog +logS' :: (MonadLogger m, MonadIO m) => Text -> Text -> m ()+logS' src msg = logS src msg >> flushLog+ debug :: MonadLogger m => Text -> m () debug = logDebugN +debugS :: MonadLogger m => Text -> Text -> m ()+debugS = logDebugNS+ debug' :: (MonadLogger m, MonadIO m) => Text -> m () debug' msg = debug msg >> flushLog +debugS' :: (MonadLogger m, MonadIO m) => Text -> Text -> m ()+debugS' src msg = debugS src msg >> flushLog+ warn :: MonadLogger m => Text -> m () warn = logWarnN +warnS :: MonadLogger m => Text -> Text -> m ()+warnS = logWarnNS+ warn' :: (MonadLogger m, MonadIO m) => Text -> m () warn' msg = warn msg >> flushLog +warnS' :: (MonadLogger m, MonadIO m) => Text -> Text -> m ()+warnS' src msg = warnS src msg >> flushLog+ -- | A logging variant of 'error' which uses 'unsafePerformIO' to output a log -- message before calling 'error'. errorL :: Text -> a@@ -159,12 +229,26 @@ errorL' :: Text -> a errorL' str = error (unsafePerformIO (logErrorN str >> flushLog) `seq` unpack str) +errorSL :: Text -> Text -> a+errorSL src str = error (unsafePerformIO (logErrorNS src str) `seq` unpack str)++errorSL' :: Text -> Text -> a+errorSL' src str =+ error (unsafePerformIO (logErrorNS src str >> flushLog) `seq` unpack str)+ traceL :: Text -> a -> a traceL str = trace (unsafePerformIO (logDebugN str) `seq` unpack str) traceL' :: Text -> a -> a traceL' str = trace (unsafePerformIO (logDebugN str >> flushLog) `seq` unpack str) +traceSL :: Text -> Text -> a -> a+traceSL src str = trace (unsafePerformIO (logDebugNS src str) `seq` unpack str)++traceSL' :: Text -> Text -> a -> a+traceSL' src str =+ trace (unsafePerformIO (logDebugNS src str >> flushLog) `seq` unpack str)+ traceShowL :: Show a => a -> a1 -> a1 traceShowL x = let s = show x@@ -175,6 +259,16 @@ let s = show x in trace (unsafePerformIO (logDebugN (pack s) >> flushLog) `seq` s) +traceShowSL :: Show a => Text -> a -> a1 -> a1+traceShowSL src x =+ let s = show x+ in trace (unsafePerformIO (logDebugNS src (pack s)) `seq` s)++traceShowSL' :: Show a => Text -> a -> a1 -> a1+traceShowSL' src x =+ let s = show x+ in trace (unsafePerformIO (logDebugNS src (pack s) >> flushLog) `seq` s)+ doTimedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => (Text -> m ()) -> Bool -> Text -> m () -> m () doTimedLog logf wrapped msg f = do@@ -204,6 +298,14 @@ => Text -> m () -> m () timedLog' msg f = doTimedLog log True msg f >> flushLog +timedLogS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedLogS src = doTimedLog (logS src) True++timedLogS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedLogS' src msg f = doTimedLog (logS src) True msg f >> flushLog+ -- | Like 'timedLog', except that it does only logs when the action has -- completed or failed after it is done. timedLogEnd :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)@@ -214,6 +316,14 @@ => Text -> m () -> m () timedLogEnd' msg f = doTimedLog log False msg f >> flushLog +timedLogEndS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedLogEndS src = doTimedLog (logS src) False++timedLogEndS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedLogEndS' src msg f = doTimedLog (logS src) False msg f >> flushLog+ -- | A debug variant of 'timedLog'. timedDebug :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => Text -> m () -> m ()@@ -223,6 +333,14 @@ => Text -> m () -> m () timedDebug' msg f = doTimedLog debug True msg f >> flushLog +timedDebugS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedDebugS src = doTimedLog (debugS src) True++timedDebugS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedDebugS' src msg f = doTimedLog (debugS src) True msg f >> flushLog+ timedDebugEnd :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => Text -> m () -> m () timedDebugEnd = doTimedLog debug False@@ -230,3 +348,11 @@ timedDebugEnd' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => Text -> m () -> m () timedDebugEnd' msg f = doTimedLog debug False msg f >> flushLog++timedDebugEndS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedDebugEndS src = doTimedLog (debugS src) False++timedDebugEndS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m)+ => Text -> Text -> m () -> m ()+timedDebugEndS' src msg f = doTimedLog (debugS src) False msg f >> flushLog
logging.cabal view
@@ -1,5 +1,5 @@ Name: logging-Version: 1.1.0+Version: 1.2.0 Synopsis: Simplified logging in IO for application writers. License-file: LICENSE License: MIT@@ -18,7 +18,9 @@ to log from IO to the console. If you need to log to other sources, or to make logging compile-time optional, use @monad-logger@ directly. .- - A set of shorter functions to type: 'debug', 'log', 'warn'.+ - A set of shorter functions to type: 'debug', 'log', 'warn', plus others+ that flush after each message, or which allow providing a message source+ string. . - Logging variants of 'error', 'trace' and 'traceShow', called 'errorL', 'traceL' and 'traceShowL'. These use 'unsafePerformIO' in order to act as@@ -51,6 +53,7 @@ , transformers >= 0.3.0.0 , lifted-base >= 0.2.2.0 , vector-space >= 0.8.6+ , pcre-light >= 0.4 exposed-modules: Control.Logging default-extensions: @@ -69,5 +72,6 @@ , logging , unix >= 2.5.1.1 , hspec >= 1.4+ , monad-logger >= 0.3.4.0 default-extensions: OverloadedStrings
test/main.hs view
@@ -1,8 +1,9 @@ module Main where -import Control.Exception import Control.Concurrent+import Control.Exception import Control.Logging+import Control.Monad.Logger import Prelude hiding (log) import Test.Hspec @@ -11,7 +12,7 @@ main :: IO () main = hspec $ do- describe "simple logging" $+ describe "simple logging" $ do it "logs output" $ (withStdoutLogging :: IO () -> IO ()) $ do log "Hello, world!" timedLog "Did a good thing" $ threadDelay 100000@@ -19,3 +20,13 @@ threadDelay 100000 >> error "foo" _ <- tryAny $ errorL "Uh oh" return ()++ it "can be passed to runLoggingT" $ do+ flip runLoggingT loggingLogger $ (log "Hello" :: LoggingT IO ())+ flushLog++ it "supports using debug classes" $ do+ setDebugSourceRegexp "foo\\..*"+ withStdoutLogging $ do+ debugS "foo" "This is a foo message"+ debugS "foo.bar" "This is a foo.bar message"