log-warper 1.0.3 → 1.0.4

raw patch · 3 files changed

+59/−19 lines, 3 filesdep +mmorphPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: mmorph

API changes (from Hackage documentation)

Files

• log-warper.cabal +2/−1
• src/System/Wlog/CanLog.hs +50/−17
• src/System/Wlog/LoggerNameBox.hs +7/−1

@@ -1,5 +1,5 @@ name:                log-warper-version:             1.0.3+version:             1.0.4 synopsis:            Flexible, configurable, monadic and pretty logging homepage:            https://github.com/serokell/log-warper license:             MIT@@ -54,6 +54,7 @@                      , lens                 >= 4.14                      , monad-control        >= 1.0.1.0                      , monad-loops          >= 0.4.3+                     , mmorph               >= 1.0.9                      , mtl                  >= 2.2.1                      , network              >= 2.6.3.1                      , safecopy             >= 0.9.1

@@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE Rank2Types            #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-}@@ -25,6 +26,8 @@        , dispatchEvents        , runPureLog        , launchPureLog++       , NamedPureLogger (..)        , runNamedPureLog        , launchNamedPureLog @@ -40,6 +43,7 @@ import           Control.Concurrent         (modifyMVar_) import           Control.Monad.Base         (MonadBase) import           Control.Monad.Except       (ExceptT, MonadError)+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.Strict as StateStrict@@ -123,23 +127,19 @@ newtype PureLogger m a = PureLogger     { runPureLogger :: WriterT (DL.DList LogEvent) m a     } deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DL.DList LogEvent),-                MonadBase b, MonadState s, MonadReader r, MonadError e, HasLoggerName)+                MonadBase b, MonadState s, MonadReader r, MonadError e, MonadThrow,+                HasLoggerName)  instance Monad m => CanLog (PureLogger m) where     dispatchMessage leLoggerName leSeverity leMessage = tell [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) . runWriterT . runPureLogger --- | Return log of pure logging action as list of 'LogEvent',--- using logger name provided by context.-runNamedPureLog-    :: (Monad m, HasLoggerName m)-    => PureLogger (LoggerNameBox m) a -> m (a, [LogEvent])-runNamedPureLog action =-    getLoggerName >>= (`usingLoggerName` runPureLog action)- -- | Logs all 'LogEvent'`s from given list. This function supposed to -- be used after 'runPureLog'. dispatchEvents :: CanLog m => [LogEvent] -> m ()@@ -148,16 +148,49 @@     dispatchLogEvent (LogEvent name sev t) = dispatchMessage name sev t  -- | Performs actual logging once given action completes.-launchPureLog :: CanLog m => PureLogger m a -> m a-launchPureLog action = do-    (res, logs) <- runPureLog action-    dispatchEvents logs-    return res+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, MonadWriter (DL.DList LogEvent),+                MonadBase b, MonadState s, MonadReader r, MonadError e,+                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 m => PureLogger (LoggerNameBox m) a -> m a-launchNamedPureLog action =-    getLoggerName >>= (`usingLoggerName` launchPureLog action)+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

@@ -16,7 +16,9 @@ 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@@ -83,7 +85,8 @@ newtype LoggerNameBox m a = LoggerNameBox     { loggerNameBoxEntry :: ReaderT LoggerName m a     } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadBase b,-                MonadThrow, MonadCatch, MonadMask, MonadState s, MonadFix)+                MonadThrow, MonadCatch, MonadMask, MonadError e, MonadState s,+                MonadFix)  instance MonadReader r m => MonadReader r (LoggerNameBox m) where     ask = lift ask@@ -95,6 +98,9 @@     liftBaseWith io =         LoggerNameBox $ liftBaseWith $ \runInBase -> io $ runInBase . loggerNameBoxEntry     restoreM = LoggerNameBox . restoreM++instance MFunctor LoggerNameBox where+    hoist f = LoggerNameBox . hoist f . loggerNameBoxEntry  -- | Runs a `LoggerNameBox` with specified initial `LoggerName`. usingLoggerName :: LoggerName -> LoggerNameBox m a -> m a