summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorlarsk <>2015-02-13 09:33:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-02-13 09:33:00 (GMT)
commit7fabbd1e4808e3e42ee323c27714308dbd8abfa8 (patch)
tree6260c69a231025685d800ec1952c45460957abab
parentd1ca7a3667c244ee3f544d6486561ec414df7b4f (diff)
version 0.10.1
-rw-r--r--CHANGELOG.md13
-rw-r--r--src/System/Logger/Internal.hs12
-rw-r--r--src/System/Logger/Logger.hs14
-rw-r--r--src/System/Logger/Logger/Internal.hs27
-rw-r--r--src/System/Logger/Types.hs60
-rw-r--r--yet-another-logger.cabal4
6 files changed, 66 insertions, 64 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 053a791..2780f88 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,16 @@
+0.1
+===
+
+* Added `localScope` function to `MonadLog` and and implemented `withLabel`
+ based on it.
+
+* Added functions `popLabel` and `clearScope`. These are useful when setting
+ log-labels for bracket style functions.
+
+* Remove overlapping `MonadLog` instances.
+
+* Lift `MonadTrace` instances into `LoggerCtxT`.
+
0.0.1
=====
diff --git a/src/System/Logger/Internal.hs b/src/System/Logger/Internal.hs
index 2e9f4c4..74e6c48 100644
--- a/src/System/Logger/Internal.hs
+++ b/src/System/Logger/Internal.hs
@@ -24,18 +24,6 @@
-- Stability: experimental
--
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnicodeSyntax #-}
module System.Logger.Internal
diff --git a/src/System/Logger/Logger.hs b/src/System/Logger/Logger.hs
index 9c377e8..751688f 100644
--- a/src/System/Logger/Logger.hs
+++ b/src/System/Logger/Logger.hs
@@ -32,20 +32,6 @@
-- The definitions in "System.Logger.Types" are re-exported by this module.
--
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
module System.Logger.Logger
diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs
index 493ad31..899a836 100644
--- a/src/System/Logger/Logger/Internal.hs
+++ b/src/System/Logger/Logger/Internal.hs
@@ -31,19 +31,14 @@
-- module as an example and starting point.
--
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
@@ -301,14 +296,14 @@ releaseLogger Logger{..} = liftIO $ do
-- > withConsoleLogger
-- > ∷ (MonadIO m, MonadBaseControl IO m)
-- > ⇒ LogLevel
--- > → (LoggerT T.Text m α)
+-- > → LoggerT T.Text m α
-- > → m α
--- > withConsoleLogger level = do
--- > backend ← mkHandleLoggerBackend $ config ^. loggerConfigBackend
--- > withLogger config backend ∘ flip runLoggerT
--- > where
--- > config = defaultLoggerConfig
--- > & loggerConfigThreshold .~ level
+-- > withConsoleLogger level inner = do
+-- > withHandleBackend (config ^. logConfigBackend) $ \backend →
+-- > withLogger (config ^. logConfigLogger) backend $ runLoggerT inner
+-- > where
+-- > config = defaultLogConfig
+-- > & logConfigLogger ∘ loggerConfigThreshold .~ level
--
withLogger
∷ (MonadIO μ, MonadBaseControl IO μ)
diff --git a/src/System/Logger/Types.hs b/src/System/Logger/Types.hs
index fa3cdf6..c393136 100644
--- a/src/System/Logger/Types.hs
+++ b/src/System/Logger/Types.hs
@@ -25,15 +25,15 @@
-- Stability: experimental
--
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -76,6 +76,9 @@ module System.Logger.Types
-- * MonadLog
, MonadLog(..)
+, withLabel
+, clearScope
+, popLabel
) where
@@ -89,6 +92,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Control
import Control.Monad.Trans.Either
import Control.Monad.State
+import Control.Monad.Trace
import Control.Monad.Trans.Trace
import Control.Monad.Writer
import Control.Monad.Unicode
@@ -268,87 +272,98 @@ type LogFunction a m = LogLevel → a → m ()
class Monad m ⇒ MonadLog a m | m → a where
logg ∷ LogFunction a m
withLevel ∷ LogLevel → m α → m α
- withLabel ∷ LogLabel → m α → m α
withPolicy ∷ LogPolicy → m α → m α
+ localScope ∷ (LogScope → LogScope) → m α → m α
+withLabel ∷ MonadLog a m ⇒ LogLabel → m α → m α
+withLabel = localScope ∘ (:)
+
+popLabel ∷ MonadLog a m ⇒ m α → m α
+popLabel = localScope $ \case { [] → []; (_:t) → t }
+
+clearScope ∷ MonadLog a m ⇒ m α → m α
+clearScope = localScope $ const []
+
+{-
-- Not sure if this instance is a good idea
instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a, MonadReader ctx m) ⇒ MonadLog a m where
logg l m = ask ≫= \ctx → liftIO (loggerFunIO ctx l m)
withLevel level = local $ setLoggerLevel .~ level
- withLabel label = local $ setLoggerScope %~ (:) label
withPolicy policy = local $ setLoggerPolicy .~ policy
+ localScope = local ∘ over setLoggerScope
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
-- Not sure if this instance is a good idea
instance MonadLog a m ⇒ MonadLog a (ReaderT σ m) where
logg l = lift ∘ logg l
withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return
- withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return
withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return
+ localScope f inner = liftWith (\run → localScope f (run inner)) ≫= restoreT ∘ return
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
+-}
instance (Monoid σ, MonadLog a m) ⇒ MonadLog a (WriterT σ m) where
logg l = lift ∘ logg l
withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return
- withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return
withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return
+ localScope f inner = liftWith (\run → localScope f (run inner)) ≫= restoreT ∘ return
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
instance (MonadLog a m) ⇒ MonadLog a (ExceptT ε m) where
logg l = lift ∘ logg l
withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return
- withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return
withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return
+ localScope f inner = liftWith (\run → localScope f (run inner)) ≫= restoreT ∘ return
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
instance (MonadLog a m) ⇒ MonadLog a (StateT σ m) where
logg l = lift ∘ logg l
withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return
- withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return
withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return
+ localScope f inner = liftWith (\run → localScope f (run inner)) ≫= restoreT ∘ return
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
instance (MonadLog a m) ⇒ MonadLog a (TraceT t e m) where
logg l = lift ∘ logg l
withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return
- withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return
withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return
+ localScope f inner = liftWith (\run → localScope f (run inner)) ≫= restoreT ∘ return
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
instance (MonadLog a m) ⇒ MonadLog a (EitherT σ m) where
logg l = lift ∘ logg l
withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return
- withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return
withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return
+ localScope f inner = liftWith (\run → localScope f (run inner)) ≫= restoreT ∘ return
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
{-
-- Uses @OverlappingInstances@ to lift MonadLog in all transformers with an
@@ -407,7 +422,12 @@ class LoggerCtx ctx msg | ctx → msg where
{-# INLINE withLoggerPolicy #-}
newtype LoggerCtxT ctx m α = LoggerCtxT { unLoggerCtxT ∷ ReaderT ctx m α }
- deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadReader ctx, MonadError a, MonadState a, MonadWriter a, MonadBase a)
+ deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadReader ctx, MonadError a, MonadState a, MonadWriter a, MonadBase a, MonadTrace t)
+
+-- This should eventually be defined in Control.Monad.Trace.Class
+instance (Monad m, MonadTrace t m) ⇒ MonadTrace t (ReaderT ctx m) where
+ traceScope s inner = liftWith (\run → traceScope s (run inner)) ≫= restoreT ∘ return
+ readTrace = lift readTrace
instance MonadTransControl (LoggerCtxT ctx) where
type StT (LoggerCtxT ctx) a = StT (ReaderT ctx) a
@@ -428,11 +448,11 @@ runLoggerCtxT = runReaderT ∘ unLoggerCtxT
instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a) ⇒ MonadLog a (LoggerCtxT ctx m) where
logg l m = ask ≫= \ctx → liftIO (loggerFunIO ctx l m)
withLevel level = local $ setLoggerLevel .~ level
- withLabel label = local $ setLoggerScope %~ (:) label
withPolicy policy = local $ setLoggerPolicy .~ policy
+ localScope f = local $ setLoggerScope %~ f
{-# INLINE logg #-}
{-# INLINE withLevel #-}
- {-# INLINE withLabel #-}
{-# INLINE withPolicy #-}
+ {-# INLINE localScope #-}
diff --git a/yet-another-logger.cabal b/yet-another-logger.cabal
index 98b53b1..31795d7 100644
--- a/yet-another-logger.cabal
+++ b/yet-another-logger.cabal
@@ -1,5 +1,5 @@
Name: yet-another-logger
-Version: 0.0.1
+Version: 0.1
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.0.1
+ tag: 0.1
Library
default-language: Haskell2010