diff --git a/Control/Logging.hs b/Control/Logging.hs --- a/Control/Logging.hs +++ b/Control/Logging.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} -- | Quick example of how to use this module: -- @@ -71,10 +72,8 @@ import Data.Maybe (isJust) import Data.Monoid import Data.Text as T -import Data.Text.Encoding as T import Data.Time import Data.Time.Locale.Compat (defaultTimeLocale) -import Debug.Trace import Prelude hiding (log) import System.IO.Unsafe import System.Log.FastLogger @@ -101,7 +100,7 @@ logTimeFormat :: IORef String {-# NOINLINE logTimeFormat #-} -logTimeFormat = unsafePerformIO $ newIORef "%T" +logTimeFormat = unsafePerformIO $ newIORef "%F %T" -- | Set the format used for log timestamps. setLogTimeFormat :: String -> IO () @@ -130,7 +129,7 @@ Nothing -> True Just re -> lvl /= LevelDebug || isJust (matchRegex re (T.unpack src)) when willLog $ do - now <- getCurrentTime + now <- getZonedTime fmt <- readIORef logTimeFormat let stamp = formatTime defaultTimeLocale fmt now set <- readIORef logSet @@ -243,37 +242,37 @@ error (unsafePerformIO (logError src str >> flushLog) `seq` unpack str) traceL :: Text -> a -> a -traceL str = trace (unsafePerformIO (debug str) `seq` unpack str) +traceL str x = unsafePerformIO (debug str) `seq` x traceL' :: Text -> a -> a -traceL' str = trace (unsafePerformIO (debug str >> flushLog) `seq` unpack str) +traceL' str x = unsafePerformIO (debug str >> flushLog) `seq` x traceSL :: Text -> Text -> a -> a -traceSL src str = trace (unsafePerformIO (debugS src str) `seq` unpack str) +traceSL src str x = unsafePerformIO (debugS src str) `seq` x traceSL' :: Text -> Text -> a -> a -traceSL' src str = - trace (unsafePerformIO (debugS src str >> flushLog) `seq` unpack str) +traceSL' src str x = + unsafePerformIO (debugS src str >> flushLog) `seq` x -traceShowL :: Show a => a -> a1 -> a1 +traceShowL :: Show a => a -> a traceShowL x = - let s = show x - in trace (unsafePerformIO (debug (pack s)) `seq` s) + let s = Prelude.show x + in unsafePerformIO (debug (pack s)) `seq` x -traceShowL' :: Show a => a -> a1 -> a1 +traceShowL' :: Show a => a -> a traceShowL' x = - let s = show x - in trace (unsafePerformIO (debug (pack s) >> flushLog) `seq` s) + let s = Prelude.show x + in unsafePerformIO (debug (pack s) >> flushLog) `seq` x -traceShowSL :: Show a => Text -> a -> a1 -> a1 +traceShowSL :: Show a => Text -> a -> a traceShowSL src x = - let s = show x - in trace (unsafePerformIO (debugS src (pack s)) `seq` s) + let s = Prelude.show x + in unsafePerformIO (debugS src (pack s)) `seq` x -traceShowSL' :: Show a => Text -> a -> a1 -> a1 +traceShowSL' :: Show a => Text -> a -> a traceShowSL' src x = - let s = show x - in trace (unsafePerformIO (debugS src (pack s) >> flushLog) `seq` s) + let s = Prelude.show x + in unsafePerformIO (debugS src (pack s) >> flushLog) `seq` x doTimedLog :: (MonadBaseControl IO m, MonadIO m) => (Text -> IO ()) -> Bool -> Text -> m a -> m a @@ -281,7 +280,7 @@ start <- liftIO getCurrentTime when wrapped $ (liftIO . logf) $ msg <> "..." res <- f `catch` \e -> do - let str = show (e :: SomeException) + let str = Prelude.show (e :: SomeException) wrapup start $ pack $ if wrapped then "...FAIL (" ++ str ++ ")" @@ -292,7 +291,8 @@ where wrapup start m = do end <- liftIO getCurrentTime - liftIO . logf $ msg <> m <> " [" <> pack (show (diffUTCTime end start)) <> "]" + liftIO . logf $ + msg <> m <> " [" <> pack (Prelude.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 diff --git a/logging.cabal b/logging.cabal --- a/logging.cabal +++ b/logging.cabal @@ -1,5 +1,5 @@ Name: logging -Version: 3.0.5 +Version: 3.0.6 Synopsis: Simplified logging in IO for application writers. License-file: LICENSE License: MIT @@ -53,12 +53,12 @@ default-extensions: BangPatterns FlexibleContexts - OverloadedStrings + -- OverloadedStrings test-suite test hs-source-dirs: test default-language: Haskell2010 - main-is: main.hs + main-is: Main.hs type: exitcode-stdio-1.0 ghc-options: -Wall -threaded build-depends: diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,49 @@ +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Logging +import Prelude hiding (log) +import Test.Hspec + +tryAny :: IO a -> IO (Either SomeException a) +tryAny = try + +main :: IO () +main = hspec $ + + describe "simple logging" $ do + + it "logs output" $ withStdoutLogging $ 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 "supports setting log levels" $ do + setLogLevel LevelWarn + + withStdoutLogging $ do + debugS "Set LogLevel test" "This is an unshown debug message" + logS "Set LogLevel test" "This is an unshown info message" + warnS "Set LogLevel test" "This is a shown info message" + _ <- tryAny $ errorSL "Set LogLevel test" "This is a shown error message" + return () + + -- setting the log level back to debug so that following tests run + setLogLevel LevelDebug + + it "supports using debug classes" $ do + setDebugSourceRegex "(foo\\.|baaz).*" + withStdoutLogging $ do + debugS "foo" "This is an unshown debug message" + debugS "foo.bar" "This is a shown debug message" + debugS "baaz.quux" "This is a shown debug message" + debugS "baaz" "This is a shown debug message" + -- checking that non-debug messages aren't filtered + logS "bar" "This is a shown log message" + logS "foo.bar" "This is a shown log message" + warnS "foo" "This is a shown warn message" diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Main where - -import Control.Concurrent -import Control.Exception -import Control.Logging -import Prelude hiding (log) -import Test.Hspec - -tryAny :: IO a -> IO (Either SomeException a) -tryAny = try - -main :: IO () -main = hspec $ - - describe "simple logging" $ do - - it "logs output" $ withStdoutLogging $ 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 "supports setting log levels" $ do - setLogLevel LevelWarn - - withStdoutLogging $ do - debugS "Set LogLevel test" "This is an unshown debug message" - logS "Set LogLevel test" "This is an unshown info message" - warnS "Set LogLevel test" "This is a shown info message" - _ <- tryAny $ errorSL "Set LogLevel test" "This is a shown error message" - return () - - -- setting the log level back to debug so that following tests run - setLogLevel LevelDebug - - it "supports using debug classes" $ do - setDebugSourceRegex "(foo\\.|baaz).*" - withStdoutLogging $ do - debugS "foo" "This is an unshown debug message" - debugS "foo.bar" "This is a shown debug message" - debugS "baaz.quux" "This is a shown debug message" - debugS "baaz" "This is a shown debug message" - -- checking that non-debug messages aren't filtered - logS "bar" "This is a shown log message" - logS "foo.bar" "This is a shown log message" - warnS "foo" "This is a shown warn message"