log-warper 1.4.1 → 1.5.0

raw patch · 13 files changed

+281/−284 lines, 13 filesdep −safecopyPVP ok

version bump matches the API change (PVP)

Dependencies removed: safecopy

API changes (from Hackage documentation)

Files

• CHANGES.md +11/−0
• log-warper.cabal +3/−2
• src/System/Wlog.hs +4/−0
• src/System/Wlog/CanLog.hs +13/−123
• src/System/Wlog/Handler.hs +9/−5
• src/System/Wlog/HasLoggerName.hs +67/−0
• src/System/Wlog/Launcher.hs +2/−3
• src/System/Wlog/Logger.hs +28/−56
• src/System/Wlog/LoggerName.hs +7/−14
• src/System/Wlog/LoggerNameBox.hs +8/−73
• src/System/Wlog/PureLogging.hs +125/−0
• src/System/Wlog/Severity.hs +2/−6
• src/System/Wlog/Wrapper.hs +2/−2

@@ -1,3 +1,14 @@+1.5.0+=====++* Replace `String` to `Text` in `LoggerName`.+* Rename `LoggerName` field name to `getLoggerName`.+* Rename `getLoggerName` of `HasLoggerName` class to `askLoggerName`.+* Use `LoggerName` instead of `Text` where possible.+* Make separate `HasLoggerName` module.+* Make separate `PureLogging` module.+* Remove `safecopy` dependency and refactor code.+ 1.4.1 ===== 

@@ -1,5 +1,5 @@ name:                log-warper-version:             1.4.1+version:             1.5.0 synopsis:            Flexible, configurable, monadic and pretty logging homepage:            https://github.com/serokell/log-warper license:             MIT@@ -24,11 +24,13 @@                        System.Wlog.Handler.Roller                        System.Wlog.Handler.Simple                        System.Wlog.Handler.Syslog+                       System.Wlog.HasLoggerName                        System.Wlog.Launcher                        System.Wlog.Logger                        System.Wlog.LoggerConfig                        System.Wlog.LoggerName                        System.Wlog.LoggerNameBox+                       System.Wlog.PureLogging                        System.Wlog.Severity                        System.Wlog.Wrapper @@ -55,7 +57,6 @@                      , mmorph               >= 1.0.9                      , mtl                  >= 2.2.1                      , network              >= 2.6.3.1-                     , safecopy             >= 0.9.1                      , text                 >= 1.2.2.0                      , text-format          >= 0.3.1.1                      , time                 >= 1.6.0.1

@@ -17,11 +17,13 @@        , module System.Wlog.Handler.Roller        , module System.Wlog.Handler.Simple        , module System.Wlog.Handler.Syslog+       , module System.Wlog.HasLoggerName        , module System.Wlog.Launcher        , module System.Wlog.Logger        , module System.Wlog.LoggerConfig        , module System.Wlog.LoggerName        , module System.Wlog.LoggerNameBox+       , module System.Wlog.PureLogging        , module System.Wlog.Severity        , module System.Wlog.Wrapper        ) where@@ -31,10 +33,12 @@ import           System.Wlog.Handler.Roller import           System.Wlog.Handler.Simple import           System.Wlog.Handler.Syslog+import           System.Wlog.HasLoggerName import           System.Wlog.Launcher import           System.Wlog.Logger import           System.Wlog.LoggerConfig import           System.Wlog.LoggerName import           System.Wlog.LoggerNameBox+import           System.Wlog.PureLogging import           System.Wlog.Severity import           System.Wlog.Wrapper

@@ -5,10 +5,7 @@ {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedLists       #-} {-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ViewPatterns          #-}  -- | Type class that add ability to log messages. -- Supports pure and IO logging.@@ -16,19 +13,7 @@        ( CanLog (..)        , WithLogger -         -- * Pure logging manipulation-       , PureLogger (..)-       , LogEvent   (..)-       , dispatchEvents-       , logEvents-       , runPureLog-       , launchPureLog--       , NamedPureLogger (..)-       , runNamedPureLog-       , launchNamedPureLog--         -- * Logging functions+       -- * Logging functions        , logDebug        , logError        , logInfo@@ -39,21 +24,17 @@  import           Universum -import           Control.Monad.Except       (ExceptT)-import           Control.Monad.Morph        (MFunctor (..))-import qualified Control.Monad.RWS          as RWSLazy-import qualified Control.Monad.RWS.Strict   as RWSStrict-import qualified Control.Monad.State.Lazy   as StateLazy-import           Control.Monad.State.Strict (modify')-import           Control.Monad.Trans        (MonadTrans (lift))-import qualified Data.DList                 as DL (DList, snoc)-import           Data.SafeCopy              (base, deriveSafeCopySimple)+import           Control.Monad.Except      (ExceptT)+import qualified Control.Monad.RWS         as RWSLazy+import qualified Control.Monad.RWS.Strict  as RWSStrict+import qualified Control.Monad.State.Lazy  as StateLazy+import           Control.Monad.Trans       (MonadTrans (lift)) -import           System.Wlog.Logger         (logM)-import           System.Wlog.LoggerName     (LoggerName (..))-import           System.Wlog.LoggerNameBox  (HasLoggerName (..), LoggerNameBox (..),-                                             usingLoggerName)-import           System.Wlog.Severity       (Severity (..))+import           System.Wlog.HasLoggerName (HasLoggerName (..))+import           System.Wlog.Logger        (logM)+import           System.Wlog.LoggerName    (LoggerName (..))+import           System.Wlog.LoggerNameBox (LoggerNameBox (..))+import           System.Wlog.Severity      (Severity (..))   -- | Type alias for constraints 'CanLog' and 'HasLoggerName'.@@ -75,7 +56,7 @@     dispatchMessage name sev t = lift $ dispatchMessage name sev t  instance CanLog IO where-    dispatchMessage (loggerName -> name) prior msg = logM name prior msg+    dispatchMessage name prior msg = logM name prior msg  instance CanLog m => CanLog (LoggerNameBox m) instance CanLog m => CanLog (ReaderT r m)@@ -85,97 +66,6 @@ instance (CanLog m, Monoid w) => CanLog (RWSLazy.RWST r w s m) instance (CanLog m, Monoid w) => CanLog (RWSStrict.RWST r w s m) --- | Holds all required information for 'dispatchLoggerName' function.-data LogEvent = LogEvent-    { leLoggerName :: !LoggerName-    , leSeverity   :: !Severity-    , leMessage    :: !Text-    } deriving (Show)--deriveSafeCopySimple 0 'base ''LogEvent---- | Pure implementation of 'CanLog' type class. Instead of writing log messages--- into console it appends log messages into 'StateT' log. It uses 'DList' for--- better performance, because messages can be added only at the end of log.--- But it uses 'unsafePerformIO' so use with caution within IO.------ TODO: Should we use some @Data.Tree@-like structure to observe message only--- by chosen logger names?-newtype PureLogger m a = PureLogger-    { runPureLogger :: StateT (DL.DList LogEvent) m a-    } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (DL.DList LogEvent),-                MonadThrow, HasLoggerName)--instance Monad m => CanLog (PureLogger m) where-    dispatchMessage leLoggerName leSeverity leMessage = modify' (flip DL.snoc LogEvent{..})--instance MFunctor PureLogger where-    hoist f = PureLogger . hoist f . runPureLogger---- | Return log of pure logging action as list of 'LogEvent'.-runPureLog :: Monad m => PureLogger m a -> m (a, [LogEvent])-runPureLog = fmap (second toList) . flip runStateT mempty . runPureLogger---- | Logs all 'LogEvent'`s from given list. This function supposed to--- be used after 'runPureLog'.-dispatchEvents :: CanLog m => [LogEvent] -> m ()-dispatchEvents = mapM_ dispatchLogEvent-  where-    dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t---- | Logs all 'LogEvent'`s from given list. Just like--- 'dispatchEvents' but uses proper logger Name.-logEvents :: WithLogger m => [LogEvent] -> m ()-logEvents events = do-    logName <- getLoggerName-    mapM_ (dispatchLogEvent logName) events-  where-    dispatchLogEvent logName (LogEvent _ sev t) = dispatchMessage logName sev t---- | Performs actual logging once given action completes.-launchPureLog-    :: (CanLog n, Monad m)-    => (forall f. Functor f => m (f a) -> n (f b))-    -> PureLogger m a-    -> n b-launchPureLog hoist' action = do-    (logs, res) <- hoist' $ swap <$> runPureLog action-    res <$ dispatchEvents logs--newtype NamedPureLogger m a = NamedPureLogger-    { runNamedPureLogger :: PureLogger (LoggerNameBox m) a-    } deriving (Functor, Applicative, Monad, MonadState (DL.DList LogEvent),-                MonadThrow, HasLoggerName)--instance MonadTrans NamedPureLogger where-    lift = NamedPureLogger . lift . lift--instance Monad m => CanLog (NamedPureLogger m) where-    dispatchMessage name sev msg =-        NamedPureLogger $ dispatchMessage name sev msg--instance MFunctor NamedPureLogger where-    hoist f = NamedPureLogger . hoist (hoist f) . runNamedPureLogger---- | Return log of pure logging action as list of 'LogEvent',--- using logger name provided by context.-runNamedPureLog-    :: (Monad m, HasLoggerName m)-    => NamedPureLogger m a -> m (a, [LogEvent])-runNamedPureLog (NamedPureLogger action) =-    getLoggerName >>= (`usingLoggerName` runPureLog action)---- | Similar as `launchPureLog`, but provides logger name from current context.-launchNamedPureLog-    :: (WithLogger n, Monad m)-    => (forall f. Functor f => m (f a) -> n (f b))-    -> NamedPureLogger m a-    -> n b-launchNamedPureLog hoist' (NamedPureLogger action) = do-    name <- getLoggerName-    (logs, res) <- hoist' $ swap <$> usingLoggerName name (runPureLog action)-    res <$ dispatchEvents logs- -- | Shortcut for 'logMessage' to use according severity. logDebug, logInfo, logNotice, logWarning, logError     :: WithLogger m@@ -193,5 +83,5 @@     -> Text     -> m () logMessage severity t = do-    name <- getLoggerName+    name <- askLoggerName     dispatchMessage name severity t

@@ -26,10 +26,13 @@        , LogHandler(..)        ) where +import           Universum+ import           Data.Text.Lazy.Builder as B+ import           System.Wlog.Formatter  (LogFormatter, nullFormatter)+import           System.Wlog.LoggerName (LoggerName (..)) import           System.Wlog.Severity   (LogRecord (..), Severity)-import           Universum  -- | Tag identifying handlers. data LogHandlerTag@@ -58,15 +61,16 @@      -- | Logs an event if it meets the requirements     -- given by the most recent call to 'setLevel'.-    handle :: a -> LogRecord -> String -> IO ()+    handle :: a -> LogRecord -> LoggerName -> IO ()     handle h lr@(LR pri _) logname =         when (pri >= (getLevel h)) $ do-            formattedMsg <- (getFormatter h) h lr (toText logname)-            emit h formattedMsg logname+            let lName = getLoggerName logname+            formattedMsg <- (getFormatter h) h lr lName+            emit h formattedMsg lName      -- | Forces an event to be logged regardless of     -- the configured level.-    emit :: a -> B.Builder -> String -> IO ()+    emit :: a -> B.Builder -> Text -> IO ()      -- | Read back from logger (e.g. file), newest first. You specify     -- the number of (newest) logging entries. Logger can return @pure

@@ -0,0 +1,67 @@+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- | This module contains type class for 'HasLoggerName'.++module System.Wlog.HasLoggerName+       ( -- * Remove boilerplater+         HasLoggerName (..)+       , setLoggerName+       ) where++import           Universum++import           Control.Monad.Except       (ExceptT (..))+import           Control.Monad.Morph        (MFunctor (..))+import qualified Control.Monad.RWS          as RWSLazy+import qualified Control.Monad.RWS.Strict   as RWSStrict+import qualified Control.Monad.State        as StateLazy (StateT)+import           Control.Monad.State.Strict (StateT)+import           Control.Monad.Trans        (MonadTrans, lift)+import           Control.Monad.Trans.Cont   (ContT, mapContT)+import           Control.Monad.Writer       (WriterT (..))++import           System.Wlog.LoggerName     (LoggerName)++-- | This type class exists to remove boilerplate logging+-- by adding the logger's name to the context in each module.+--+-- TODO: replace current methods with Lens?+class HasLoggerName m where+    -- | Extract logger name from context+    askLoggerName :: m LoggerName++    -- | Change logger name in context+    modifyLoggerName :: (LoggerName -> LoggerName) -> m a -> m a++    default askLoggerName :: (MonadTrans t, t n ~ m, Monad n, HasLoggerName n) => m LoggerName+    askLoggerName = lift askLoggerName++    default modifyLoggerName :: (MFunctor t, t n ~ m, Monad n, HasLoggerName n)+                             => (LoggerName -> LoggerName)+                             -> m a+                             -> m a+    modifyLoggerName f = hoist (modifyLoggerName f)++instance (Monad m, HasLoggerName m) => HasLoggerName (ReaderT a m) where+instance (Monad m, HasLoggerName m) => HasLoggerName (StateT a m) where+instance (Monad m, HasLoggerName m) => HasLoggerName (StateLazy.StateT a m) where+instance (Monoid w, Monad m, HasLoggerName m) => HasLoggerName (WriterT w m) where+instance (Monad m, HasLoggerName m) => HasLoggerName (ExceptT e m) where+instance (Monad m, HasLoggerName m) => HasLoggerName (ContT r m) where+    askLoggerName    = lift askLoggerName+    modifyLoggerName = mapContT . modifyLoggerName++instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSLazy.RWST r w s m) where+instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSStrict.RWST r w s m) where++instance HasLoggerName Identity where+    askLoggerName    = Identity "Identity"+    modifyLoggerName = flip const++-- | Set logger name in context.+setLoggerName :: HasLoggerName m => LoggerName -> m a -> m a+setLoggerName = modifyLoggerName . const

@@ -37,7 +37,6 @@ import           Control.Error.Util         ((?:)) import           Control.Exception          (throwIO) import qualified Data.HashMap.Strict        as HM hiding (HashMap)-import qualified Data.Text                  as T import           Data.Time                  (UTCTime) import           Data.Yaml                  (decodeFileEither) import           System.Directory           (createDirectoryIfMissing)@@ -103,10 +102,10 @@                     let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded timeF r)                     let fmt = maybe defFmt roundFmt _hwRounding                     thisLoggerHandler <- fmt <$> handlerCreator-                    updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler+                    updateGlobalLogger parent $ addHandler thisLoggerHandler          for_ (HM.toList _ltSubloggers) $ \(name, loggerConfig) -> do-            let thisLoggerName = LoggerName $ T.unpack name+            let thisLoggerName = LoggerName name             let thisLogger     = parent <> logMapper thisLoggerName             processLoggers thisLogger loggerConfig 

@@ -54,21 +54,22 @@        , retrieveLogContent        ) where +import           Universum+ import           Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar) import           Control.Lens            (makeLenses)-import           Data.List               (isPrefixOf) import qualified Data.Map                as M import           Data.Maybe              (fromJust) import qualified Data.Text               as T import qualified Data.Text.IO            as TIO import           System.FilePath         ((</>)) import           System.IO.Unsafe        (unsafePerformIO)-import           Universum  import           System.Wlog.Handler     (LogHandler (getTag),                                           LogHandlerTag (HandlerFilelike), close,                                           readBack) import qualified System.Wlog.Handler     (handle)+import           System.Wlog.LoggerName  (LoggerName (..)) import           System.Wlog.Severity    (LogRecord (..), Severity (..))  @@ -81,15 +82,15 @@ data Logger = Logger     { _lLevel    :: Maybe Severity     , _lHandlers :: [HandlerT]-    , _lName     :: String+    , _lName     :: LoggerName     } deriving (Generic)  makeLenses ''Logger -type LogTree = Map String Logger+type LogTree = Map LoggerName Logger  data LogInternalState = LogInternalState-    { liTree   :: Map String Logger+    { liTree   :: LogTree     , liPrefix :: Maybe FilePath     } deriving (Generic) @@ -99,8 +100,8 @@  -- | The name of the root logger, which is always defined and present -- on the system.-rootLoggerName :: String-rootLoggerName = ""+rootLoggerName :: LoggerName+rootLoggerName = mempty  --------------------------------------------------------------------------- -- Logger Tree Storage@@ -124,14 +125,14 @@ >["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"]  -}-componentsOfName :: String -> [String]-componentsOfName name =-    rootLoggerName : joinComp (split "." name) []+componentsOfName :: LoggerName -> [LoggerName]+componentsOfName (LoggerName name) =+    rootLoggerName : (LoggerName <$> (joinComp (T.splitOn "." name) ""))   where     joinComp [] _ = []-    joinComp (x:xs) [] = x : joinComp xs x+    joinComp (x:xs) "" = x : joinComp xs x     joinComp (x:xs) accum =-        let newlevel = accum ++ "." ++ x+        let newlevel = accum <> "." <> x         in newlevel : joinComp xs newlevel  ---------------------------------------------------------------------------@@ -139,7 +140,7 @@ ---------------------------------------------------------------------------  -- | Log a message using the given logger at a given priority.-logM :: String     -- ^ Name of the logger to use+logM :: LoggerName -- ^ Name of the logger to use      -> Severity   -- ^ Severity of this message      -> Text       -- ^ The log text itself      -> IO ()@@ -147,7 +148,7 @@     l <- getLogger logname     logL l pri msg -logMCond :: String -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO ()+logMCond :: LoggerName -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO () logMCond logname sev msg cond = do     l <- getLogger logname     logLCond l sev msg cond@@ -157,31 +158,31 @@ ---------------------------------------------------------------------------  {- | Log a message at 'Debug' priority -}-debugM :: String                       -- ^ Logger name+debugM :: LoggerName                   -- ^ Logger name        -> Text                         -- ^ Log message        -> IO () debugM s = logM s Debug  {- | Log a message at 'Info' priority -}-infoM :: String                        -- ^ Logger name+infoM :: LoggerName                    -- ^ Logger name       -> Text                          -- ^ Log message       -> IO () infoM s = logM s Info  {- | Log a message at 'Notice' priority -}-noticeM :: String                      -- ^ Logger name+noticeM :: LoggerName                  -- ^ Logger name         -> Text                        -- ^ Log message         -> IO () noticeM s = logM s Notice  {- | Log a message at 'Warning' priority -}-warningM :: String                     -- ^ Logger name+warningM :: LoggerName                 -- ^ Logger name          -> Text                       -- ^ Log message          -> IO () warningM s = logM s Warning  {- | Log a message at 'Error' priority -}-errorM :: String                       -- ^ Logger name+errorM :: LoggerName                   -- ^ Logger name        -> Text                         -- ^ Log message        -> IO () errorM s = logM s Error@@ -193,7 +194,7 @@ -- | Returns the logger for the given name.  If no logger with that name -- exists, creates new loggers and any necessary parent loggers, with -- no connected handlers.-getLogger :: String -> IO Logger+getLogger :: LoggerName -> IO Logger getLogger lname = modifyMVar logInternalState $ \lt@LogInternalState{..} ->     case M.lookup lname liTree of       Just x ->  return (lt, x) -- A logger exists; return it and leave tree@@ -203,7 +204,7 @@           let result = fromJust $ M.lookup lname newlt           return (LogInternalState newlt liPrefix, result)   where-    createLoggers :: [String] -> LogTree -> LogTree+    createLoggers :: [LoggerName] -> LogTree -> LogTree     createLoggers [] lt = lt -- No names to add; return tree unmodified     createLoggers (x:xs) lt = -- Add logger to tree         createLoggers xs $@@ -228,24 +229,23 @@ handle :: Logger -> LogRecord -> (LogHandlerTag -> Bool) -> IO () handle l lrecord@(LR sev _) handlerFilter = do     lp <- getLoggerSeverity nm-    if sev >= lp then do+    when (sev >= lp) $ do         ph <- concatMap (view lHandlers) <$> parentLoggers nm         forM_ ph $ callHandler lrecord nm-    else return ()   where     nm = view lName l-    parentLoggers :: String -> IO [Logger]+    parentLoggers :: LoggerName -> IO [Logger]     parentLoggers = mapM getLogger . componentsOfName     -- Get the severity we should use. Find the first logger in the     -- tree, starting here, with a set severity. If even root doesn't     -- have one, assume "Debug".-    getLoggerSeverity :: String -> IO Severity+    getLoggerSeverity :: LoggerName -> IO Severity     getLoggerSeverity name = do         pl <- parentLoggers name         case catMaybes . map (view lLevel) $ (l : pl) of             []    -> pure Debug             (x:_) -> pure x-    callHandler :: LogRecord -> String -> HandlerT -> IO ()+    callHandler :: LogRecord -> LoggerName -> HandlerT -> IO ()     callHandler lr loggername (HandlerT x) =         when (handlerFilter $ getTag x) $             System.Wlog.Handler.handle x lr loggername@@ -308,7 +308,7 @@ -- > updateGlobalLogger "MyApp.BuggyComponent" -- >                    (setLevel DEBUG . setHandlers [s]) updateGlobalLogger-    :: String -- ^ Logger name+    :: LoggerName         -- ^ Logger name     -> (Logger -> Logger) -- ^ Function to call     -> IO () updateGlobalLogger ln func =@@ -328,7 +328,7 @@ -- -- Takes a logger name, priority, leading description text (you can set it to -- @\"\"@ if you don't want any), and action to run.-traplogging :: String     -- ^ Logger name+traplogging :: LoggerName -- ^ Logger name             -> Severity   -- ^ Logging priority             -> Text       -- ^ Descriptive text to prepend to logged messages             -> IO a       -- ^ Action to run@@ -371,31 +371,3 @@             []  -> takeMaybe . reverse . T.lines <$> TIO.readFile filePathFull             xs  -> error $ "Found more than one (" <> show (length xs) <>                            "handle with the same filePath tag, impossible."--------------------------------------------------------------------------------- List util functions--------------------------------------------------------------------------------- | This function pulled in from MissingH to avoid a dep on it-split :: Eq a => [a] -> [a] -> [[a]]-split _ [] = []-split delim str =-    let (firstline, remainder) = breakList (isPrefixOf delim) str-    in firstline :-       case remainder of-           [] -> []-           x | x == delim -> [] : []-             | otherwise -> split delim (drop (length delim) x)---- This function also pulled from MissingH-breakList :: ([a] -> Bool) -> [a] -> ([a], [a])-breakList func = spanList (not . func)---- This function also pulled from MissingH-spanList :: ([a] -> Bool) -> [a] -> ([a], [a])-spanList _ [] = ([],[])-spanList func l@(x:xs) =-    let (ys, zs) = spanList func xs-    in if func l-       then (x : ys, zs)-       else ([], l)

@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- | Contains @newtype@ wrapper around logger name to support hierarchy.  module System.Wlog.LoggerName@@ -7,25 +5,20 @@        , loggerNameF        ) where +import           Universum+ import           Data.Hashable       (Hashable)-import           Data.SafeCopy       (base, deriveSafeCopySimple) import           Data.Semigroup      (Semigroup) import qualified Data.Semigroup      as Semigroup import           Data.String         (IsString) import           Data.Text.Buildable (Buildable) import qualified Data.Text.Buildable as Buildable-import           Formatting          (Format, bprint, build, string)-import           Universum+import           Formatting          (Format, bprint, build, stext)  -- | Logger name to keep in context.---- TODO: replace 'String' with 'Text'--- TODO: change field name into @getLoggerName@ to follow naming convention newtype LoggerName = LoggerName-    { loggerName :: String-    } deriving (Show, IsString, Eq, Hashable)--deriveSafeCopySimple 0 'base ''LoggerName+    { getLoggerName :: Text+    } deriving (Show, IsString, Eq, Ord, Hashable)  -- | Defined such that @n1@ is parent for @(n1 <> n2)@ -- (see <http://hackage.haskell.org/package/hslogger-1.2.10/docs/System-Log-Logger.html hslogger description>).@@ -33,14 +26,14 @@     LoggerName parent <> LoggerName suffix         | null parent = LoggerName suffix         | null suffix = LoggerName parent-        | otherwise   = LoggerName $ parent ++ "." ++ suffix+        | otherwise   = LoggerName $ parent <> "." <> suffix  instance Monoid LoggerName where     mempty = ""     mappend = (Semigroup.<>)  instance Buildable LoggerName where-    build = bprint string . loggerName+    build = bprint stext . getLoggerName  -- | 'LoggerName' formatter which restricts type. loggerNameF :: Format r (LoggerName -> r)

@@ -7,90 +7,25 @@  module System.Wlog.LoggerNameBox        ( -- * Remove boilerplater-         HasLoggerName (..)-       , LoggerNameBox (..)-       , setLoggerName+         LoggerNameBox (..)        , usingLoggerName        ) where +import           Universum+ import           Control.Monad.Base          (MonadBase) import           Control.Monad.Catch         (MonadCatch, MonadMask, MonadThrow)-import           Control.Monad.Except        (ExceptT (..), mapExceptT) import           Control.Monad.Except        (MonadError) import           Control.Monad.Fix           (MonadFix) import           Control.Monad.Morph         (MFunctor (..))-import           Control.Monad.Reader        (MonadReader (..), ReaderT, mapReaderT,-                                              runReaderT)-import qualified Control.Monad.RWS           as RWSLazy-import qualified Control.Monad.RWS.Strict    as RWSStrict-import qualified Control.Monad.State         as StateLazy (StateT, mapStateT)-import           Control.Monad.State.Strict  (MonadState, StateT, mapStateT)+import           Control.Monad.Reader        (MonadReader (..), ReaderT, runReaderT)+import           Control.Monad.State.Strict  (MonadState) import           Control.Monad.Trans         (MonadIO, MonadTrans, lift)-import           Control.Monad.Trans.Cont    (ContT, mapContT) import           Control.Monad.Trans.Control (MonadBaseControl (..))-import           Control.Monad.Writer        (WriterT (..), mapWriterT)-import           Universum +import           System.Wlog.HasLoggerName   (HasLoggerName (..)) import           System.Wlog.LoggerName      (LoggerName) --- | This type class exists to remove boilerplate logging--- by adding the logger's name to the context in each module.------ TODO: replace current methods with Lens?-class HasLoggerName m where-    -- | Extract logger name from context-    getLoggerName :: m LoggerName--    -- | Change logger name in context-    modifyLoggerName :: (LoggerName -> LoggerName) -> m a -> m a--instance (Monad m, HasLoggerName m) => HasLoggerName (ReaderT a m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = mapReaderT . modifyLoggerName--instance (Monad m, HasLoggerName m) => HasLoggerName (StateT a m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = mapStateT . modifyLoggerName--instance (Monad m, HasLoggerName m) => HasLoggerName (StateLazy.StateT a m) where-    getLoggerName = lift getLoggerName-    modifyLoggerName = StateLazy.mapStateT . modifyLoggerName--instance (Monoid w, Monad m, HasLoggerName m) => HasLoggerName (WriterT w m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = mapWriterT . modifyLoggerName--instance (Monad m, HasLoggerName m) => HasLoggerName (ExceptT e m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = mapExceptT . modifyLoggerName--instance (Monad m, HasLoggerName m) => HasLoggerName (ContT r m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = mapContT . modifyLoggerName--instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSLazy.RWST r w s m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = RWSLazy.mapRWST . modifyLoggerName--instance (Monad m, HasLoggerName m, Monoid w) => HasLoggerName (RWSStrict.RWST r w s m) where-    getLoggerName = lift getLoggerName--    modifyLoggerName = RWSStrict.mapRWST . modifyLoggerName--instance HasLoggerName Identity where-    getLoggerName    = Identity "Identity"-    modifyLoggerName = flip const---- | Set logger name in context.-setLoggerName :: HasLoggerName m => LoggerName -> m a -> m a-setLoggerName = modifyLoggerName . const- -- | Default implementation of `WithNamedLogger`. newtype LoggerNameBox m a = LoggerNameBox     { loggerNameBoxEntry :: ReaderT LoggerName m a@@ -101,7 +36,7 @@ instance MonadReader r m => MonadReader r (LoggerNameBox m) where     ask = lift ask     reader = lift . reader-    local f (LoggerNameBox m) = getLoggerName >>= lift . local f . runReaderT m+    local f (LoggerNameBox m) = askLoggerName >>= lift . local f . runReaderT m  instance MonadBaseControl b m => MonadBaseControl b (LoggerNameBox m) where     type StM (LoggerNameBox m) a = StM (ReaderT LoggerName m) a@@ -117,6 +52,6 @@ usingLoggerName name = flip runReaderT name . loggerNameBoxEntry  instance Monad m => HasLoggerName (LoggerNameBox m) where-    getLoggerName = LoggerNameBox ask+    askLoggerName = LoggerNameBox ask      modifyLoggerName how = LoggerNameBox . local how . loggerNameBoxEntry

@@ -0,0 +1,125 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE TypeFamilies          #-}++-- | This module supports pure logging.+module System.Wlog.PureLogging+       (+       -- * Pure logging manipulation+         PureLogger (..)+       , LogEvent   (..)+       , dispatchEvents+       , logEvents+       , runPureLog+       , launchPureLog++       , NamedPureLogger (..)+       , runNamedPureLog+       , launchNamedPureLog+       ) where++import           Universum++import           Control.Monad.Morph        (MFunctor (..))+import           Control.Monad.State.Strict (modify')+import           Control.Monad.Trans        (MonadTrans (lift))+import qualified Data.DList                 as DL (DList, snoc)++import           System.Wlog.CanLog         (CanLog (..), WithLogger)+import           System.Wlog.HasLoggerName  (HasLoggerName (..))+import           System.Wlog.LoggerName     (LoggerName (..))+import           System.Wlog.LoggerNameBox  (LoggerNameBox (..), usingLoggerName)+import           System.Wlog.Severity       (Severity (..))++-- | Holds all required information for 'dispatchLoggerName' function.+data LogEvent = LogEvent+    { leLoggerName :: !LoggerName+    , leSeverity   :: !Severity+    , leMessage    :: !Text+    } deriving (Show)++-- | Pure implementation of 'CanLog' type class. Instead of writing log messages+-- into console it appends log messages into 'StateT' log. It uses 'DList' for+-- better performance, because messages can be added only at the end of log.+-- But it uses 'unsafePerformIO' so use with caution within IO.+--+-- TODO: Should we use some @Data.Tree@-like structure to observe message only+-- by chosen logger names?+newtype PureLogger m a = PureLogger+    { runPureLogger :: StateT (DL.DList LogEvent) m a+    } deriving (Functor, Applicative, Monad, MonadTrans, MonadState (DL.DList LogEvent),+                MonadThrow, HasLoggerName)++instance Monad m => CanLog (PureLogger m) where+    dispatchMessage leLoggerName leSeverity leMessage = modify' (flip DL.snoc LogEvent{..})++instance MFunctor PureLogger where+    hoist f = PureLogger . hoist f . runPureLogger++-- | Return log of pure logging action as list of 'LogEvent'.+runPureLog :: Monad m => PureLogger m a -> m (a, [LogEvent])+runPureLog = fmap (second toList) . flip runStateT mempty . runPureLogger++-- | Logs all 'LogEvent'`s from given list. This function supposed to+-- be used after 'runPureLog'.+dispatchEvents :: CanLog m => [LogEvent] -> m ()+dispatchEvents = mapM_ dispatchLogEvent+  where+    dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t++-- | Logs all 'LogEvent'`s from given list. Just like+-- 'dispatchEvents' but uses proper logger Name.+logEvents :: WithLogger m => [LogEvent] -> m ()+logEvents events = do+    logName <- askLoggerName+    mapM_ (dispatchLogEvent logName) events+  where+    dispatchLogEvent logName (LogEvent _ sev t) = dispatchMessage logName sev t++-- | Performs actual logging once given action completes.+launchPureLog+    :: (CanLog n, Monad m)+    => (forall f. Functor f => m (f a) -> n (f b))+    -> PureLogger m a+    -> n b+launchPureLog hoist' action = do+    (logs, res) <- hoist' $ swap <$> runPureLog action+    res <$ dispatchEvents logs++newtype NamedPureLogger m a = NamedPureLogger+    { runNamedPureLogger :: PureLogger (LoggerNameBox m) a+    } deriving (Functor, Applicative, Monad, MonadState (DL.DList LogEvent),+                MonadThrow, HasLoggerName)++instance MonadTrans NamedPureLogger where+    lift = NamedPureLogger . lift . lift++instance Monad m => CanLog (NamedPureLogger m) where+    dispatchMessage name sev msg =+        NamedPureLogger $ dispatchMessage name sev msg++instance MFunctor NamedPureLogger where+    hoist f = NamedPureLogger . hoist (hoist f) . runNamedPureLogger++-- | Return log of pure logging action as list of 'LogEvent',+-- using logger name provided by context.+runNamedPureLog+    :: (Monad m, HasLoggerName m)+    => NamedPureLogger m a -> m (a, [LogEvent])+runNamedPureLog (NamedPureLogger action) =+    askLoggerName >>= (`usingLoggerName` runPureLog action)++-- | Similar as `launchPureLog`, but provides logger name from current context.+launchNamedPureLog+    :: (WithLogger n, Monad m)+    => (forall f. Functor f => m (f a) -> n (f b))+    -> NamedPureLogger m a+    -> n b+launchNamedPureLog hoist' (NamedPureLogger action) = do+    name <- askLoggerName+    (logs, res) <- hoist' $ swap <$> usingLoggerName name (runPureLog action)+    res <$ dispatchEvents logs

@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- | Custom wrapper around @hslogger.Priority@.  module System.Wlog.Severity@@ -7,11 +5,11 @@        , LogRecord(..)        ) where -import           Data.SafeCopy (base, deriveSafeCopySimple)+import           Universum+ import           Data.Typeable (Typeable) import           Data.Yaml     (FromJSON, ToJSON) import           GHC.Generics  (Generic)-import           Universum  -- | Severity is level of log message importance. It uniquely -- determines which messages to print.@@ -25,8 +23,6 @@  instance FromJSON Severity instance ToJSON   Severity--deriveSafeCopySimple 0 'base ''Severity  -- | Internal type of log records. data LogRecord = LR !Severity !Text deriving Show

@@ -90,14 +90,14 @@  -- | Set severity for given logger. By default parent's severity is used. setSeverity :: MonadIO m => LoggerName -> Severity -> m ()-setSeverity (LoggerName name) =+setSeverity name =     liftIO . updateGlobalLogger name . setLevel  -- | Set or clear severity. setSeverityMaybe     :: MonadIO m     => LoggerName -> Maybe Severity -> m ()-setSeverityMaybe (LoggerName name) Nothing =+setSeverityMaybe name Nothing =     liftIO $ updateGlobalLogger name clearLevel setSeverityMaybe n (Just x) = setSeverity n x