summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorlarsk <>2015-04-23 14:49:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-04-23 14:49:00 (GMT)
commit84a9fd047b6ec19a41dc145887eaaf54aebe02cc (patch)
treef51e5d7f953b3f301f38795bbf819b28604ff053
parent3028a502066f85f99382c7cbc3ab837e1d5e329c (diff)
version 0.2.20.2.2
-rw-r--r--CHANGELOG.md12
-rw-r--r--constraints28
-rw-r--r--src/System/Logger.hs5
-rw-r--r--src/System/Logger/Backend/ColorOption.hs5
-rw-r--r--src/System/Logger/Backend/Handle.hs52
-rw-r--r--src/System/Logger/Internal.hs10
-rw-r--r--src/System/Logger/Logger/Internal.hs19
-rw-r--r--src/System/Logger/Types.hs59
-rw-r--r--test/TastyTools.hs11
-rw-r--r--yet-another-logger.cabal4
10 files changed, 179 insertions, 26 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7c61c4d..0973697 100644
--- 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
index 8c59eb6..f413d3b 100644
--- 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 @@ constraints: Cabal ==1.22.2.0,
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 @@ constraints: Cabal ==1.22.2.0,
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 @@ constraints: Cabal ==1.22.2.0,
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 @@ constraints: Cabal ==1.22.2.0,
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 @@ constraints: Cabal ==1.22.2.0,
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 @@ constraints: Cabal ==1.22.2.0,
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
index be91154..4cb417d 100644
--- a/src/System/Logger.hs
+++ b/src/System/Logger.hs
@@ -162,6 +162,11 @@ instance FromJSON (LogConfig → LogConfig) where
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
index e6e9479..f8cd1cf 100644
--- a/src/System/Logger/Backend/ColorOption.hs
+++ b/src/System/Logger/Backend/ColorOption.hs
@@ -116,6 +116,11 @@ instance FromJSON ColorOption where
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
index 07b87b2..680ae1c 100644
--- a/src/System/Logger/Backend/Handle.hs
+++ b/src/System/Logger/Backend/Handle.hs
@@ -56,7 +56,9 @@ module System.Logger.Backend.Handle
-- * Backend Implementation
, withHandleBackend
+, withHandleBackend_
, handleBackend
+, handleBackend_
) where
import Configuration.Utils hiding (Lens', Error)
@@ -138,6 +140,11 @@ instance FromJSON LoggerHandleConfig where
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 @@ instance FromJSON (HandleBackendConfig → HandleBackendConfig) where
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 @@ withHandleBackend
⇒ 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 @@ withHandleBackend conf inner =
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 @@ handleBackend h colored eitherMsg = do
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
index f464042..3772ce8 100644
--- a/src/System/Logger/Internal.hs
+++ b/src/System/Logger/Internal.hs
@@ -56,6 +56,8 @@ sshow = fromString ∘ show
-- | Format 'TimeSpec' as ISO8601 date-time string with
-- microseconds precision.
--
+-- @since 0.2
+--
formatIso8601Micro
∷ IsString a
⇒ TimeSpec
@@ -65,6 +67,8 @@ formatIso8601Micro = formatIso8601 6
-- | Format 'TimeSpec' as ISO8601 date-time string with
-- milliseconds precision.
--
+-- @since 0.2
+--
formatIso8601Milli
∷ IsString a
⇒ TimeSpec
@@ -74,6 +78,8 @@ formatIso8601Milli = formatIso8601 3
-- | Format 'TimeSpec' as ISO8601 date-time string with
-- the given sub-second precision.
--
+-- @since 0.2
+--
formatIso8601
∷ IsString a
⇒ Natural
@@ -83,13 +89,15 @@ formatIso8601
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
→ UTCTime
diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs
index 21d42d6..c828d72 100644
--- a/src/System/Logger/Logger/Internal.hs
+++ b/src/System/Logger/Logger/Internal.hs
@@ -150,13 +150,21 @@ data LoggerConfig = LoggerConfig
-- 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 @@ instance FromJSON (LoggerConfig → LoggerConfig) where
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 @@ createLogger = createLogger_ (T.hPutStrLn stderr)
-- | 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 @@ withLogger = withLogger_ (T.hPutStrLn stderr)
-- | 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 ())
@@ -580,6 +597,8 @@ withLogFunction = withLogFunction_ (T.hPutStrLn stderr)
-- | 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 μ)
⇒ (T.Text → IO ())
diff --git a/src/System/Logger/Types.hs b/src/System/Logger/Types.hs
index b0cdae2..a275b5a 100644
--- a/src/System/Logger/Types.hs
+++ b/src/System/Logger/Types.hs
@@ -89,7 +89,7 @@ module System.Logger.Types
) where
-import Configuration.Utils hiding (Lens', Error)
+import Configuration.Utils hiding (Lens, Lens', Error)
import Control.DeepSeq
import Control.Exception
@@ -167,6 +167,11 @@ instance FromJSON LogLevel where
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 @@ instance FromJSON LogPolicy where
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 @@ type LogScope = [LogLabel]
-- -------------------------------------------------------------------------- --
-- 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 @@ data LogMessage a = LogMessage
-- 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 @@ logMsgLevel = lens _logMsgLevel $ \a b → a { _logMsgLevel = b }
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 @@ type LogFunction a m = LogLevel → a → m ()
-- 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
index 5bc5fd4..fecc28f 100644
--- 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 @@ module TastyTools
, 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 @@ instance IsOption OptionVerbose where
-- | Function to report progress
--
type ProgressFunction
- = MonadIO m
+ = ∀ m . MonadIO m
⇒ Float
-- ^ progress measure
→ T.Text
@@ -121,7 +128,7 @@ testCaseProgress testName = singleTest (T.unpack testName) ∘ TestCaseProgress
-- | 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
index bd702a5..e712f88 100644
--- 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 @@ source-repository this
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