diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +0.2.2 +===== + +* [Issue #28] Generalized type of lens `logMsg` to support changing + the message type. + +* [Issue #29] Fixed precision of `formatIso8601` function. + +* [Issue #30] Added a version of `withHandleBackend` that is generic + in the log message type and accept a formatting function for + formatting the log message as text. + 0.2.1 ===== diff --git a/constraints b/constraints --- a/constraints +++ b/constraints @@ -1,5 +1,5 @@ -constraints: Cabal ==1.22.2.0, - MonadRandom ==0.3.0.1, +constraints: Cabal ==1.22.3.0, + MonadRandom ==0.3.0.2, StateVar ==1.1.0.0, adjunctions ==4.2, aeson ==0.8.0.2, @@ -10,12 +10,12 @@ asn1-parse ==0.9.0, asn1-types ==0.3.0, async ==2.0.2, - attoparsec ==0.12.1.5, + attoparsec ==0.12.1.6, base ==4.8.0.0, base-unicode-symbols ==0.2.2.4, base64-bytestring ==1.0.0.1, bifunctors ==4.2.1, - binary ==0.7.3.0, + binary ==0.7.4.0, blaze-builder ==0.4.0.1, byteable ==0.1.1, bytestring ==0.10.6.0, @@ -24,12 +24,12 @@ cipher-aes ==0.2.10, cipher-des ==0.0.6, cipher-rc4 ==0.1.4, - clock ==0.4.1.3, + clock ==0.4.5.0, comonad ==4.2.5, conduit ==1.2.4, configuration-tools ==0.2.12, connection ==0.2.4, - containers ==0.5.6.2, + containers ==0.5.6.3, contravariant ==1.3.1, cookie ==0.4.1.4, crypto-cipher-types ==0.0.9, @@ -57,12 +57,12 @@ ghc-prim ==0.4.0.0, hashable ==1.2.3.2, hourglass ==0.2.8, - http-client ==0.4.9, + http-client ==0.4.11.1, http-client-tls ==0.2.2, http-types ==0.8.6, integer-gmp ==1.0.0.0, kan-extensions ==4.2.1, - lens ==4.8, + lens ==4.9.1, lifted-base ==0.2.3.6, mime-types ==0.1.0.6, mmorph ==1.0.4, @@ -77,7 +77,7 @@ parsec ==3.1.9, pem ==0.2.2, prelude-extras ==0.4, - pretty ==1.1.2.0, + pretty ==1.1.3.2, primitive ==0.5.4.0, process ==1.2.3.0, profunctors ==4.4.1, @@ -94,13 +94,13 @@ socks ==0.5.4, stm ==2.4.4, stm-chans ==3.0.0.3, - streaming-commons ==0.1.10.0, + streaming-commons ==0.1.12, syb ==0.4.4, - tagged ==0.7.3, + tagged ==0.8.0.1, template-haskell ==2.10.0.0, text ==1.2.0.4, time ==1.5.0.1, - tls ==1.2.16, + tls ==1.2.17, trace ==0.2.0.0, transformers ==0.4.2.0, transformers-base ==0.4.4, @@ -114,5 +114,5 @@ x509-store ==1.5.0, x509-system ==1.5.0, x509-validation ==1.5.1, - yaml ==0.8.10.1, - zlib ==0.5.4.2 + yaml ==0.8.11, + zlib ==0.6.1.0 diff --git a/src/System/Logger.hs b/src/System/Logger.hs --- a/src/System/Logger.hs +++ b/src/System/Logger.hs @@ -162,6 +162,11 @@ pLogConfig ∷ MParser LogConfig pLogConfig = pLogConfig_ "" +-- | A version of 'pLogConfig' that takes a prefix for the command +-- line option. +-- +-- @since 0.2 +-- pLogConfig_ ∷ T.Text -- ^ prefix for this and all subordinate command line options. diff --git a/src/System/Logger/Backend/ColorOption.hs b/src/System/Logger/Backend/ColorOption.hs --- a/src/System/Logger/Backend/ColorOption.hs +++ b/src/System/Logger/Backend/ColorOption.hs @@ -116,6 +116,11 @@ pColorOption ∷ O.Parser ColorOption pColorOption = pColorOption_ "" +-- | A version of 'pColorOption' that takes a prefix for the +-- command line option. +-- +-- @since 0.2 +-- pColorOption_ ∷ T.Text -- ^ prefix for the command line options. diff --git a/src/System/Logger/Backend/Handle.hs b/src/System/Logger/Backend/Handle.hs --- a/src/System/Logger/Backend/Handle.hs +++ b/src/System/Logger/Backend/Handle.hs @@ -56,7 +56,9 @@ -- * Backend Implementation , withHandleBackend +, withHandleBackend_ , handleBackend +, handleBackend_ ) where import Configuration.Utils hiding (Lens', Error) @@ -138,6 +140,11 @@ pLoggerHandleConfig ∷ O.Parser LoggerHandleConfig pLoggerHandleConfig = pLoggerHandleConfig_ "" +-- | A version of 'pLoggerHandleConfig' that takes a prefix for the +-- command line option. +-- +-- @since 0.2 +-- pLoggerHandleConfig_ ∷ T.Text -- ^ prefix for the command line options. @@ -194,6 +201,11 @@ pHandleBackendConfig ∷ MParser HandleBackendConfig pHandleBackendConfig = pHandleBackendConfig_ "" +-- | A version of 'pLoggerHandleBackendConfig' that takes a prefix for the +-- command line option. +-- +-- @since 0.2 +-- pHandleBackendConfig_ ∷ T.Text -- ^ prefix for this and all subordinate command line options. @@ -210,7 +222,22 @@ ⇒ HandleBackendConfig → (LoggerBackend T.Text → m α) → m α -withHandleBackend conf inner = +withHandleBackend = withHandleBackend_ id +{-# INLINE withHandleBackend #-} + +-- | A version of 'withHandleBackend' that is generic in the type +-- of the log message. +-- +-- @since 0.2.2 +-- +withHandleBackend_ + ∷ (MonadIO m, MonadBaseControl IO m) + ⇒ (msg → T.Text) + -- ^ formatting function for the log message + → HandleBackendConfig + → (LoggerBackend msg → m α) + → m α +withHandleBackend_ format conf inner = case conf ^. handleBackendConfigHandle of StdErr → run stderr StdOut → run stdout @@ -218,21 +245,36 @@ where run h = do colored ← liftIO $ useColor (conf ^. handleBackendConfigColor) h - inner $ handleBackend h colored + inner $ handleBackend_ format h colored handleBackend ∷ Handle → Bool -- ^ whether to use ANSI color escape codes → LoggerBackend T.Text -handleBackend h colored eitherMsg = do +handleBackend = handleBackend_ id +{-# INLINE handleBackend #-} + +-- | A version of 'handleBackend' that is generic in the type of +-- the log message. +-- +-- @since 0.2.2 +-- +handleBackend_ + ∷ (msg → T.Text) + -- ^ formatting function for the log message + → Handle + → Bool + -- ^ whether to use ANSI color escape codes + → LoggerBackend msg +handleBackend_ format h colored eitherMsg = do T.hPutStrLn h $ formatIso8601Milli (msg ^. logMsgTime) ⊕ " " ⊕ inLevelColor colored ("[" ⊕ sshow level ⊕ "] ") ⊕ inScopeColor colored ("[" ⊕ formatedScope ⊕ "] ") ⊕ (msg ^. logMsg) where - msg = either id id eitherMsg + msg = either id (logMsg %~ format) eitherMsg level = msg ^. logMsgLevel formatedScope = T.intercalate "|" ∘ L.map formatLabel ∘ reverse $ msg ^. logMsgScope @@ -262,5 +304,5 @@ inBlue ∷ T.Text → T.Text inBlue = inColor A.Dull A.Blue -{-# INLINEABLE handleBackend #-} +{-# INLINEABLE handleBackend_ #-} diff --git a/src/System/Logger/Internal.hs b/src/System/Logger/Internal.hs --- a/src/System/Logger/Internal.hs +++ b/src/System/Logger/Internal.hs @@ -56,6 +56,8 @@ -- | Format 'TimeSpec' as ISO8601 date-time string with -- microseconds precision. -- +-- @since 0.2 +-- formatIso8601Micro ∷ IsString a ⇒ TimeSpec @@ -65,6 +67,8 @@ -- | Format 'TimeSpec' as ISO8601 date-time string with -- milliseconds precision. -- +-- @since 0.2 +-- formatIso8601Milli ∷ IsString a ⇒ TimeSpec @@ -74,6 +78,8 @@ -- | Format 'TimeSpec' as ISO8601 date-time string with -- the given sub-second precision. -- +-- @since 0.2 +-- formatIso8601 ∷ IsString a ⇒ Natural @@ -83,12 +89,14 @@ formatIso8601 precision = fromString ∘ (⊕ "Z") - ∘ take (fromIntegral $ 21 + precision) + ∘ take (fromIntegral $ 20 + precision) ∘ (⊕ replicate (fromIntegral precision) '0') ∘ formatTime defaultTimeLocale ("%Y-%m-%dT%H:%M:%S%Q") ∘ timeSpecToUtc -- | Convert a 'TimeSpec' value into 'UTCTime' +-- +-- @since 0.2 -- timeSpecToUtc ∷ TimeSpec diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs --- a/src/System/Logger/Logger/Internal.hs +++ b/src/System/Logger/Logger/Internal.hs @@ -150,13 +150,21 @@ -- the logger will discard all exceptions. For instance a value of @1@ -- means that an exception is raised when the second exception occurs. -- A value of @0@ means that an exception is raised for each exception. + -- + -- @since 0.2 + , _loggerConfigExceptionWait ∷ !(Maybe Natural) -- ^ number of microseconds to wait after an exception from the backend. -- If this is 'Nothing' the logger won't wait at all after an exception. + -- + -- @since 0.2 + , _loggerConfigExitTimeout ∷ !(Maybe Natural) -- ^ timeout in microseconds for the logger to flush the queue and -- deliver all remaining log messages on termination. If this is 'Nothing' -- termination of the logger blogs until all mesages are delivered. + -- + -- @since 0.2 } deriving (Show, Read, Eq, Ord, Typeable, Generic) @@ -229,6 +237,11 @@ pLoggerConfig ∷ MParser LoggerConfig pLoggerConfig = pLoggerConfig_ "" +-- | A version of 'pLoggerConfig' that takes a prefix for the +-- command line option. +-- +-- @since 0.2 +-- pLoggerConfig_ ∷ T.Text -- ^ prefix for this and all subordinate command line options. @@ -370,6 +383,8 @@ -- | A version of 'createLogger' that takes as an extra argument -- a function for logging errors in the logging system. -- +-- @since 0.2 +-- createLogger_ ∷ MonadIO μ ⇒ (T.Text → IO ()) @@ -555,6 +570,8 @@ -- | A version of 'withLogger' that takes as an extra argument -- a function for logging errors in the logging system. -- +-- @since 0.2 +-- withLogger_ ∷ (MonadIO μ, MonadBaseControl IO μ) ⇒ (T.Text → IO ()) @@ -579,6 +596,8 @@ -- | For simple cases, when the logger threshold and the logger scope is -- constant this function can be used to directly initialize a log function. +-- +-- @since 0.2 -- withLogFunction_ ∷ (Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ) diff --git a/src/System/Logger/Types.hs b/src/System/Logger/Types.hs --- a/src/System/Logger/Types.hs +++ b/src/System/Logger/Types.hs @@ -89,7 +89,7 @@ ) where -import Configuration.Utils hiding (Lens', Error) +import Configuration.Utils hiding (Lens, Lens', Error) import Control.DeepSeq import Control.Exception @@ -167,6 +167,11 @@ pLogLevel ∷ O.Parser LogLevel pLogLevel = pLogLevel_ "" +-- | A version of 'pLogLevel' that takes a prefix for the command line +-- option. +-- +-- @since 0.2 +-- pLogLevel_ ∷ T.Text -- ^ prefix for the command line options. @@ -218,6 +223,11 @@ pLogPolicy ∷ O.Parser LogPolicy pLogPolicy = pLogPolicy_ "" +-- | A version of 'pLogPolicy' that takes a prefix for the +-- command line option. +-- +-- @since 0.2 +-- pLogPolicy_ ∷ T.Text -- ^ prefix for the command line options. @@ -236,6 +246,19 @@ -- -------------------------------------------------------------------------- -- -- Logger Exception +-- | Exceptions that are thrown by the logger +-- +-- ['QueueFullException'] thrown when the queue is full and the logger policy +-- is set to throw exceptions on a full queue +-- +-- ['BackendTerminatedException'] a backend can throw this exception to force +-- the logger immediately +-- +-- ['BackendTooManyExceptions'] thrown when the backend has thrown unexpected +-- exceptions more than 'loggerConfigExceptionLimit' times +-- +-- @since 0.2 +-- data LoggerException a where QueueFullException ∷ LogMessage a → LoggerException a BackendTerminatedException ∷ SomeException → LoggerException Void @@ -270,10 +293,12 @@ -- on the respective system. NOTE that POSIX is ambigious with regard -- to treatment of leap seconds, and some implementations may actually -- return TAI. + -- + -- @since 0.2 } deriving (Show, Read, Eq, Ord, Typeable, Generic) -logMsg ∷ Lens' (LogMessage a) a +logMsg ∷ Lens (LogMessage a) (LogMessage b) a b logMsg = lens _logMsg $ \a b → a { _logMsg = b } logMsgLevel ∷ Lens' (LogMessage a) LogLevel @@ -282,6 +307,8 @@ logMsgScope ∷ Lens' (LogMessage a) LogScope logMsgScope = lens _logMsgScope $ \a b → a { _logMsgScope = b } +-- | @since 0.2 +-- logMsgTime ∷ Lens' (LogMessage a) TimeSpec logMsgTime = lens _logMsgTime $ \a b → a { _logMsgTime = b } @@ -328,17 +355,45 @@ -- MonadLog class Monad m ⇒ MonadLog a m | m → a where + + -- | Log a message. + -- logg ∷ LogFunction a m + + -- | Run the inner computation with the given 'LogLevel' withLevel ∷ LogLevel → m α → m α + + -- | Run the inner computation with the given 'LogPolicy'. withPolicy ∷ LogPolicy → m α → m α + + -- | Run the inner computation with a modified 'LogScope'. + -- + -- @since 0.1 + -- localScope ∷ (LogScope → LogScope) → m α → m α +-- | Append a 'LogLabel' to the current 'LogScope' when executing the +-- inner computation. The 'LogScope' of the outer computation is unchanged. +-- +-- @since 0.1 +-- withLabel ∷ MonadLog a m ⇒ LogLabel → m α → m α withLabel = localScope ∘ (:) +-- | Remove the last 'LogLabel' from the current 'LogScope' when +-- executing the inner computation. The 'LogScope' of the outer +-- computation is unchanged. +-- +-- @since 0.1 +-- popLabel ∷ MonadLog a m ⇒ m α → m α popLabel = localScope $ \case { [] → []; (_:t) → t } +-- | Executing the inner computation with an empty 'LogScope'. The +-- 'LogScope' of the outer computation is unchanged. +-- +-- @since 0.1 +-- clearScope ∷ MonadLog a m ⇒ m α → m α clearScope = localScope $ const [] diff --git a/test/TastyTools.hs b/test/TastyTools.hs --- a/test/TastyTools.hs +++ b/test/TastyTools.hs @@ -14,6 +14,7 @@ -- Stability: experimental -- +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} @@ -31,9 +32,15 @@ , testCaseSteps ) where +#ifndef MIN_VERSION_base +#define MIN_VESION_base(x,y,z) 1 +#endif + import Configuration.Utils (boolReader) +#if ! MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Control.Exception (try) import Control.Monad import Control.Monad.IO.Class @@ -67,7 +74,7 @@ -- | Function to report progress -- type ProgressFunction - = MonadIO m + = ∀ m . MonadIO m ⇒ Float -- ^ progress measure → T.Text @@ -121,7 +128,7 @@ -- | Function to report progress -- type StepFunction - = MonadIO m + = ∀ m . MonadIO m ⇒ T.Text -- ^ progress message → m () diff --git a/yet-another-logger.cabal b/yet-another-logger.cabal --- a/yet-another-logger.cabal +++ b/yet-another-logger.cabal @@ -1,5 +1,5 @@ Name: yet-another-logger -Version: 0.2.1 +Version: 0.2.2 Synopsis: Yet Another Logger Description: A logging framework written with flexibility and performance @@ -73,7 +73,7 @@ type: git location: https://github.com/alephcloud/hs-yet-another-logger branch: master - tag: 0.2.1 + tag: 0.2.2 Library default-language: Haskell2010