diff --git a/Control/Logging.hs b/Control/Logging.hs --- a/Control/Logging.hs +++ b/Control/Logging.hs @@ -3,7 +3,8 @@ -- | Quick example of how to use this module: -- --- @import Control.Logging +-- @ +-- import Control.Logging -- -- main = withStdoutLogging $ do -- log "This is a log message!" @@ -64,7 +65,6 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Logger import Control.Monad.Trans.Control import Data.Functor ((<$)) import Data.IORef @@ -76,14 +76,14 @@ import Debug.Trace import Prelude hiding (log) import System.IO.Unsafe -#if MIN_VERSION_time (1,5,0) -import System.Locale hiding (defaultTimeLocale) -#else -import System.Locale -#endif import System.Log.FastLogger import Text.Regex.PCRE.Light +data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text + deriving (Eq, Prelude.Show, Prelude.Read, Ord) + +type LogSource = Text + logLevel :: IORef LogLevel {-# NOINLINE logLevel #-} logLevel = unsafePerformIO $ newIORef LevelDebug @@ -121,12 +121,8 @@ . 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 +loggingLogger :: ToLogStr msg => LogLevel -> LogSource -> msg -> IO () +loggingLogger !lvl !src str = do maxLvl <- readIORef logLevel when (lvl >= maxLvl) $ do mre <- readIORef debugSourceRegexp @@ -187,106 +183,103 @@ set <- readIORef logSet flushLogStr set -instance MonadLogger IO where - monadLoggerLog = loggingLogger +-- You must surround the body of your @main@ function with a call to +-- 'withStdoutLogging' or 'withStderrLogging', to ensure that all logging +-- buffers are properly flushed on exit. +log :: Text -> IO () +log = loggingLogger LevelInfo "" --- | Synonym for 'Control.Monad.Logger.logInfoN'. This module provides a --- 'MonadLogger' instance for IO, so this function can be used directly in --- IO. The only requirement is that you must surround the body of your --- @main@ function with a call to 'withStdoutLogging' or --- 'withStderrLogging', to ensure that all logging buffers are properly --- flushed on exit. -log :: MonadLogger m => Text -> m () -log = logInfoN +logError :: Text -> Text -> IO () +logError = loggingLogger LevelError -logS :: MonadLogger m => Text -> Text -> m () -logS = logInfoNS +logS :: Text -> Text -> IO () +logS = loggingLogger LevelInfo -- | 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 +log' :: MonadIO m => Text -> m () +log' msg = (liftIO $ log msg) >> flushLog -logS' :: (MonadLogger m, MonadIO m) => Text -> Text -> m () -logS' src msg = logS src msg >> flushLog +logS' :: MonadIO m => Text -> Text -> m () +logS' src msg = (liftIO $ logS src msg) >> flushLog -debug :: MonadLogger m => Text -> m () -debug = logDebugN +debug :: Text -> IO () +debug = debugS "" -debugS :: MonadLogger m => Text -> Text -> m () -debugS = logDebugNS +debugS :: Text -> Text -> IO () +debugS = loggingLogger LevelDebug -debug' :: (MonadLogger m, MonadIO m) => Text -> m () -debug' msg = debug msg >> flushLog +debug' :: MonadIO m => Text -> m () +debug' msg = (liftIO $ debug msg) >> flushLog -debugS' :: (MonadLogger m, MonadIO m) => Text -> Text -> m () -debugS' src msg = debugS src msg >> flushLog +debugS' :: MonadIO m => Text -> Text -> m () +debugS' src msg = (liftIO $ debugS src msg) >> flushLog -warn :: MonadLogger m => Text -> m () -warn = logWarnN +warn :: Text -> IO () +warn = warnS "" -warnS :: MonadLogger m => Text -> Text -> m () -warnS = logWarnNS +warnS :: Text -> Text -> IO () +warnS = loggingLogger LevelWarn -warn' :: (MonadLogger m, MonadIO m) => Text -> m () -warn' msg = warn msg >> flushLog +warn' :: MonadIO m => Text -> m () +warn' msg = (liftIO $ warn msg) >> flushLog -warnS' :: (MonadLogger m, MonadIO m) => Text -> Text -> m () -warnS' src msg = warnS src msg >> flushLog +warnS' :: MonadIO m => Text -> Text -> m () +warnS' src msg = (liftIO $ warnS src msg) >> flushLog -- | A logging variant of 'error' which uses 'unsafePerformIO' to output a log -- message before calling 'error'. errorL :: Text -> a -errorL str = error (unsafePerformIO (logErrorN str) `seq` unpack str) +errorL str = error (unsafePerformIO (logError "" str) `seq` unpack str) errorL' :: Text -> a -errorL' str = error (unsafePerformIO (logErrorN str >> flushLog) `seq` unpack str) +errorL' str = error (unsafePerformIO (logError "" str >> flushLog) `seq` unpack str) errorSL :: Text -> Text -> a -errorSL src str = error (unsafePerformIO (logErrorNS src str) `seq` unpack str) +errorSL src str = error (unsafePerformIO (logError src str) `seq` unpack str) errorSL' :: Text -> Text -> a errorSL' src str = - error (unsafePerformIO (logErrorNS src str >> flushLog) `seq` unpack str) + error (unsafePerformIO (logError src str >> flushLog) `seq` unpack str) traceL :: Text -> a -> a -traceL str = trace (unsafePerformIO (logDebugN str) `seq` unpack str) +traceL str = trace (unsafePerformIO (debug str) `seq` unpack str) traceL' :: Text -> a -> a -traceL' str = trace (unsafePerformIO (logDebugN str >> flushLog) `seq` unpack str) +traceL' str = trace (unsafePerformIO (debug str >> flushLog) `seq` unpack str) traceSL :: Text -> Text -> a -> a -traceSL src str = trace (unsafePerformIO (logDebugNS src str) `seq` unpack str) +traceSL src str = trace (unsafePerformIO (debugS src str) `seq` unpack str) traceSL' :: Text -> Text -> a -> a traceSL' src str = - trace (unsafePerformIO (logDebugNS src str >> flushLog) `seq` unpack str) + trace (unsafePerformIO (debugS src str >> flushLog) `seq` unpack str) traceShowL :: Show a => a -> a1 -> a1 traceShowL x = let s = show x - in trace (unsafePerformIO (logDebugN (pack s)) `seq` s) + in trace (unsafePerformIO (debug (pack s)) `seq` s) traceShowL' :: Show a => a -> a1 -> a1 traceShowL' x = let s = show x - in trace (unsafePerformIO (logDebugN (pack s) >> flushLog) `seq` s) + in trace (unsafePerformIO (debug (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) + in trace (unsafePerformIO (debugS 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) + in trace (unsafePerformIO (debugS src (pack s) >> flushLog) `seq` s) -doTimedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) - => (Text -> m ()) -> Bool -> Text -> m a -> m a +doTimedLog :: (MonadBaseControl IO m, MonadIO m) + => (Text -> IO ()) -> Bool -> Text -> m a -> m a doTimedLog logf wrapped msg f = do start <- liftIO getCurrentTime - when wrapped $ logf $ msg <> "..." + when wrapped $ (liftIO . logf) $ msg <> "..." res <- f `catch` \e -> do let str = show (e :: SomeException) wrapup start $ pack $ @@ -299,74 +292,74 @@ where wrapup start m = do end <- liftIO getCurrentTime - logf $ msg <> m <> " [" <> pack (show (diffUTCTime end start)) <> "]" + liftIO . logf $ msg <> m <> " [" <> pack (show (diffUTCTime end start)) <> "]" -- | Output a logging message both before an action begins, and after it ends, -- reporting the total length of time. If an exception occurred, it is also -- reported. -timedLog :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLog :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedLog = doTimedLog log True -timedLog' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLog' :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedLog' msg f = doTimedLog log True msg f >>= (<$ flushLog) -timedLogS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLogS :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedLogS src = doTimedLog (logS src) True -timedLogS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLogS' :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a 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) +timedLogEnd :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedLogEnd = doTimedLog log False -timedLogEnd' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLogEnd' :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedLogEnd' msg f = doTimedLog log False msg f >>= (<$ flushLog) -timedLogEndS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLogEndS :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedLogEndS src = doTimedLog (logS src) False -timedLogEndS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedLogEndS' :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedLogEndS' src msg f = doTimedLog (logS src) False msg f >>= (<$ flushLog) -- | A debug variant of 'timedLog'. -timedDebug :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebug :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedDebug = doTimedLog debug True -timedDebug' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebug' :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedDebug' msg f = doTimedLog debug True msg f >>= (<$ flushLog) -timedDebugS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebugS :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedDebugS src = doTimedLog (debugS src) True -timedDebugS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebugS' :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedDebugS' src msg f = doTimedLog (debugS src) True msg f >>= (<$ flushLog) -timedDebugEnd :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebugEnd :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedDebugEnd = doTimedLog debug False -timedDebugEnd' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebugEnd' :: (MonadBaseControl IO m, MonadIO m) => Text -> m a -> m a timedDebugEnd' msg f = doTimedLog debug False msg f >>= (<$ flushLog) -timedDebugEndS :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebugEndS :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedDebugEndS src = doTimedLog (debugS src) False -timedDebugEndS' :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) +timedDebugEndS' :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> m a -> m a timedDebugEndS' src msg f = doTimedLog (debugS src) False msg f >>= (<$ flushLog) diff --git a/logging.cabal b/logging.cabal --- a/logging.cabal +++ b/logging.cabal @@ -1,5 +1,5 @@ Name: logging -Version: 2.2.0 +Version: 3.0.0 Synopsis: Simplified logging in IO for application writers. License-file: LICENSE License: MIT @@ -9,14 +9,9 @@ Cabal-Version: >=1.10 Category: System Description: - @logging@ is a wrapper around @monad-logger@ and @fast-logger@ which makes - it easy to log from any 'MonadLogger' environment, or from 'IO'. It - provides the following conveniences on top of those libraries: - . - - A 'MonadLogger' instance for 'IO'. Usually this is bad for libraries, but - can be very convenient for application writers who know they always want - 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. + @logging@ is a wrapper around @fast-logger@ which makes + it easy to log from 'IO'. It provides the following conveniences on top of + those libraries: . - A set of shorter functions to type: 'debug', 'log', 'warn', plus others that flush after each message, or which allow providing a message source @@ -48,14 +43,13 @@ , old-locale >= 1.0.0.5 , time >= 1.4 , monad-control >= 0.3.2.3 - , monad-logger >= 0.3.4.0 , text >= 0.11.3.1 , transformers >= 0.3.0.0 , lifted-base >= 0.2.2.0 , pcre-light >= 0.4 exposed-modules: Control.Logging - default-extensions: + default-extensions: BangPatterns FlexibleContexts OverloadedStrings @@ -71,6 +65,5 @@ , logging , unix >= 2.5.1.1 , hspec >= 1.4 - , monad-logger >= 0.3.4.0 - default-extensions: + default-extensions: OverloadedStrings diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -3,7 +3,6 @@ import Control.Concurrent import Control.Exception import Control.Logging -import Control.Monad.Logger import Prelude hiding (log) import Test.Hspec @@ -15,15 +14,12 @@ describe "simple logging" $ do it "logs output" $ (withStdoutLogging :: IO () -> IO ()) $ do log "Hello, world!" + warnS "test-suite" "you've been warned" timedLog "Did a good thing" $ threadDelay 100000 _ <- tryAny $ timedLog "Did a bad thing" $ 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 setDebugSourceRegex "foo\\..*"