log-warper 1.2.3 → 1.2.3.1

raw patch · 11 files changed

+154/−126 lines, 11 filesdep +deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq

API changes (from Hackage documentation)

Files

• log-warper.cabal +3/−1
• src/System/Wlog/CanLog.hs +10/−14
• src/System/Wlog/Color.hs +14/−13
• src/System/Wlog/Formatter.hs +68/−59
• src/System/Wlog/Handler.hs +7/−6
• src/System/Wlog/Handler/Roller.hs +2/−1
• src/System/Wlog/Handler/Simple.hs +7/−4
• src/System/Wlog/Handler/Syslog.hs +14/−11
• src/System/Wlog/Logger.hs +4/−4
• src/System/Wlog/MemoryQueue.hs +23/−11
• src/System/Wlog/Severity.hs +2/−2

@@ -1,5 +1,5 @@ name:                log-warper-version:             1.2.3+version:             1.2.3.1 synopsis:            Flexible, configurable, monadic and pretty logging homepage:            https://github.com/serokell/log-warper license:             MIT@@ -39,6 +39,7 @@                      , ansi-terminal        >= 0.6.2.3                      , base                 >= 4.7 && < 5                      , containers           >= 0.5.7.0+                     , deepseq              >= 1.2.0.0                      , directory            >= 1.2.6.2                      , dlist                >= 0.8.0.2                      , errors               >= 2.1.2@@ -70,6 +71,7 @@   ghc-options:         -Wall -fno-warn-orphans    default-extensions:  GeneralizedNewtypeDeriving+                       BangPatterns                        DeriveDataTypeable                        DeriveGeneric                        NoImplicitPrelude

@@ -8,7 +8,6 @@ {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE ViewPatterns          #-}  -- | Type class that add ability to log messages.@@ -37,15 +36,14 @@        , logMessage        ) where -import           Control.Monad.Base        (MonadBase)-import           Control.Monad.Except      (ExceptT, MonadError)+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 qualified Control.Monad.State.Strict  as StateStrict import           Control.Monad.Trans       (MonadTrans (lift))-import           Control.Monad.Writer      (MonadWriter (tell), WriterT (runWriterT))-import qualified Data.DList                as DL (DList)+import qualified Data.DList                as DL (DList, snoc) import           Data.SafeCopy             (base, deriveSafeCopySimple) import           Universum @@ -95,27 +93,26 @@ deriveSafeCopySimple 0 'base ''LogEvent  -- | Pure implementation of 'CanLog' type class. Instead of writing log messages--- into console it appends log messages into 'WriterT' log. It uses 'DList' for+-- 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 :: WriterT (DL.DList LogEvent) m a-    } deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (DL.DList LogEvent),-                MonadBase b, MonadState s, MonadReader r, MonadError e, MonadThrow,-                HasLoggerName)+    { runPureLogger :: StateStrict.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 = tell [LogEvent{..}]+    dispatchMessage leLoggerName leSeverity leMessage = StateStrict.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) . runWriterT . runPureLogger+runPureLog = fmap (second toList) . flip runStateT mempty . runPureLogger  -- | Logs all 'LogEvent'`s from given list. This function supposed to -- be used after 'runPureLog'.@@ -136,8 +133,7 @@  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,+    } deriving (Functor, Applicative, Monad, MonadState (DL.DList LogEvent),                 MonadThrow, HasLoggerName)  instance MonadTrans NamedPureLogger where

@@ -11,16 +11,18 @@  module System.Wlog.Color        ( colorizer-       , colorizerT+       , colorizerBuilder        ) where -import qualified Data.Text            as T-import           System.Console.ANSI  (Color (Blue, Green, Magenta, Red, Yellow),-                                       ColorIntensity (Vivid), ConsoleLayer (Foreground),-                                       SGR (Reset, SetColor), setSGRCode)+import qualified Data.Text              as T+import           Data.Text.Lazy.Builder as B+import           System.Console.ANSI    (Color (Blue, Green, Magenta, Red, Yellow),+                                         ColorIntensity (Vivid),+                                         ConsoleLayer (Foreground),+                                         SGR (Reset, SetColor), setSGRCode) import           Universum -import           System.Wlog.Severity (Severity (..))+import           System.Wlog.Severity   (Severity (..))  -- | Defines pre- and post-printed characters for printing colorized text. table :: Severity -> (String, String)@@ -34,12 +36,11 @@     setColor color = setSGRCode [SetColor Foreground Vivid color]     reset = setSGRCode [Reset] --- | Colorizes string text.-colorizer :: Severity -> String -> String-colorizer pr s =-    let (before, after) = table pr in before <> s <> after- -- | Colorizes "Text".-colorizerT :: Severity -> Text -> Text-colorizerT pr s =+colorizer :: Severity -> Text -> Text+colorizer pr s =     let (before, after) = table pr in T.pack before <> s <> T.pack after++colorizerBuilder :: Severity -> Builder -> Builder+colorizerBuilder pr s =+    let (before, after) = table pr in B.fromText (T.pack before) <> s <> B.fromText (T.pack after)

@@ -31,13 +31,12 @@        ) where  import           Control.Concurrent     (myThreadId)-import           Data.List              (span) import           Data.Monoid            (mconcat)-import           Data.String            (IsString) import qualified Data.Text              as T import           Data.Time              (formatTime, getCurrentTime, getZonedTime) import           Data.Time.Clock        (UTCTime (..)) import           Data.Time.Format       (FormatTime)+import           Data.Text.Lazy.Builder as B import           Formatting             (Format, sformat, shown, stext, (%)) import           Universum #ifndef mingw32_HOST_OS@@ -49,9 +48,9 @@ import           System.Locale          (defaultTimeLocale) #endif -import           System.Wlog.Color      (colorizer, colorizerT)+import           System.Wlog.Color      (colorizer) import           System.Wlog.LoggerName (LoggerName, loggerNameF)-import           System.Wlog.Severity   (LogRecord, Severity (..))+import           System.Wlog.Severity   (LogRecord(..), Severity (..))   ----------------------------------------------------------------------------@@ -63,66 +62,76 @@ -- information specific to the handler (an example of can be seen in -- the formatter used in 'System.Log.Handler.Syslog') type LogFormatter a-    =  a         -- ^ The LogHandler that the passed message came from-    -> LogRecord -- ^ The log message and priority-    -> String    -- ^ The logger name-    -> IO Text   -- ^ The formatted log message+    =  a          -- ^ The LogHandler that the passed message came from+    -> LogRecord  -- ^ The log message and priority+    -> Text       -- ^ The logger name+    -> IO Builder -- ^ The formatted log message  -- | Returns the passed message as is, ie. no formatting is done. nullFormatter :: LogFormatter a-nullFormatter _ (_,msg) _ = pure msg+nullFormatter _ (LR _ msg) _ = pure (B.fromText msg)  -- | Replace some '$' variables in a string with supplied values-replaceVarM-    :: [(String, IO Text)] -- ^ A list of (variableName, action to-                           -- get the replacement string) pairs-    -> String              -- ^ String to perform substitution on-    -> IO Text             -- ^ Resulting string-replaceVarM _ [] = pure ""-replaceVarM keyVals (span (/= '$') -> (before,after)) = do-    if null after then pure $ T.pack before-    else do-        (f, rest) <- replaceStart keyVals $ drop 1 after-        repRest <- replaceVarM keyVals rest-        pure $ T.pack before <> f <> repRest+replaceVars+    :: [(Text, Text)] -- ^ A list of (variableName, action to+                      -- get the replacement string) pairs+    -> Text           -- ^ Text to perform substitution on+    -> Builder        -- ^ Resulting string+replaceVars _ (T.null -> True) = mempty+replaceVars keyVals (T.breakOn "$" -> (before,after)) =+    if T.null after then B.fromText before+    else+        let (f, rest) = replaceStart keyVals $ T.drop 1 after+            repRest   = replaceVars keyVals rest+        in B.fromText before <> f <> repRest   where-    replaceStart [] str = return ("$", str)-    replaceStart ((k, v):kvs) str-        | k `isPrefixOf` str = do-            vs <- v-            return (vs, drop (length k) str)-        | otherwise = replaceStart kvs str+    replaceStart :: [(Text, Text)] -> Text -> (Builder, Text)+    replaceStart [] str = (B.singleton '$', str)+    replaceStart ((k, v):kvs) txt+        | k `T.isPrefixOf` txt = (B.fromText v, T.drop (T.length k) txt)+        | otherwise = replaceStart kvs txt  -- | An extensible formatter that allows new substition /variables/ to -- be defined.  Each variable has an associated IO action that is used -- to produce the string to substitute for the variable name.  The -- predefined variables are the same as for 'simpleLogFormatter' -- /excluding/ @$time@ and @$utcTime@.-varFormatter :: [(String, IO Text)] -> String -> LogFormatter a-varFormatter vars format _h (prio,msg) loggername = do-    replaceVarM (vars ++ predefinedVars) format+varFormatter :: [(Text, Text)] -> Text -> LogFormatter a+varFormatter vars format _h (LR prio msg) loggername = do+    defaultVars  <- predefinedVars+    platformVars <- osSpecificVars+    return $ replaceVars (vars <> defaultVars <> platformVars) format   where-    predefinedVars = [ ("msg", pure msg)-                     , ("prio", pure $ T.toUpper $ show prio)-                     , ("loggername", pure $ T.pack loggername)-                     , ("tid", show <$> myThreadId)+    predefinedVars = do+        tid <- T.pack . show <$> myThreadId+        pure [ ("msg", msg)+             , ("prio", T.toUpper $ show prio)+             , ("loggername", loggername)+             , ("tid", tid)+             ] #ifndef mingw32_HOST_OS-                     , ("pid", show <$> getProcessID)+    osSpecificVars = do+      pid <- T.pack . show <$> getProcessID+      pure [("pid", pid)]+#else+    osSpecificVars = return mempty #endif-                     ]   -- | Like 'simpleLogFormatter' but allow the time format to be -- specified in the first parameter (this is passed to -- 'Date.Time.Format.formatTime')-tfLogFormatter :: String -> String -> LogFormatter a-tfLogFormatter timeFormat format = do-    let ftime :: FormatTime t => t -> Text-        ftime = T.pack . formatTime defaultTimeLocale timeFormat-    varFormatter [ ("time", ftime <$> getZonedTime)-                 , ("utcTime", ftime <$> getCurrentTime)+tfLogFormatter :: Text -> Text -> LogFormatter a+tfLogFormatter timeFormat format = \h kv loggername -> do+    time    <- ftime <$> getZonedTime+    utcTime <- ftime <$> getCurrentTime+    varFormatter [ ("time", time)+                 , ("utcTime", utcTime)                  ]-        format+        format h kv loggername+  where+     ftime :: FormatTime t => t -> Text+     ftime = T.pack . formatTime defaultTimeLocale (T.unpack timeFormat)  -- | Takes a format string, and returns a formatter that may be used --   to format log messages.  The format string may contain variables@@ -142,19 +151,19 @@ --    * @$time@ - The current time -- --    * @$utcTime@ - The current time in UTC Time-simpleLogFormatter :: String -> LogFormatter a-simpleLogFormatter format h (prio, msg) loggername =-    tfLogFormatter "%F %X %Z" format h (prio,msg) loggername+simpleLogFormatter :: Text -> LogFormatter a+simpleLogFormatter format h logRecord loggername =+    tfLogFormatter "%F %X %Z" format h logRecord loggername  ---------------------------------------------------------------------------- -- Log-warper functionality ---------------------------------------------------------------------------- -timeFmt :: IsString s => s+timeFmt :: Text timeFmt = "[$time] " -timeFmtStdout :: IsString s => Bool -> s-timeFmtStdout = bool "" timeFmt+timeFmtStdout :: Bool -> Text+timeFmtStdout = bool mempty timeFmt  getRoundedTime :: Int -> IO UTCTime getRoundedTime roundN = do@@ -167,29 +176,29 @@  stderrFormatter :: Bool -> LogFormatter a stderrFormatter isShowTid = simpleLogFormatter $-    mconcat [colorizer Error $ "[$loggername:$prio" ++ tid ++ "] ", timeFmt, "$msg"]+    mconcat $! [colorizer Error $ "[$loggername:$prio" <> tid <> "] ", timeFmt, "$msg"]   where     tid = if isShowTid then ":$tid" else "" -stdoutFmt :: Severity -> Bool -> Bool -> String-stdoutFmt pr isShowTime isShowTid = mconcat-    [colorizer pr $ "[$loggername:$prio" ++ tid ++ "] ", timeFmtStdout isShowTime, "$msg"]+stdoutFmt :: Severity -> Bool -> Bool -> Text+stdoutFmt pr isShowTime isShowTid = mconcat $!+    [colorizer pr $ "[$loggername:$prio" <> tid <> "] ", timeFmtStdout isShowTime, "$msg"]   where-    tid = if isShowTid then ":$tid" else ""+    tid = if isShowTid then ":$tid" else mempty  stdoutFormatter :: Bool -> Bool -> LogFormatter a-stdoutFormatter isShowTime isShowTid handle r@(pr, _) =+stdoutFormatter isShowTime isShowTid handle r@(LR pr _) =     simpleLogFormatter (stdoutFmt pr isShowTime isShowTid) handle r  stdoutFormatterTimeRounded :: Int -> LogFormatter a-stdoutFormatterTimeRounded roundN a r@(pr,_) s = do+stdoutFormatterTimeRounded roundN a r@(LR pr _) s = do     t <- getRoundedTime roundN     simpleLogFormatter (fmt t) a r s   where-    fmt time = mconcat $+    fmt time = mconcat $!         [ colorizer pr "[$loggername:$prio:$tid]"         , " ["-        , formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" time+        , T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" time         , "] $msg"]  -- TODO: do we need coloring here?@@ -202,7 +211,7 @@ -- | Same as 'formatLogMessage', but with colorful output formatLogMessageColors :: LoggerName -> Severity -> UTCTime -> Text -> Text formatLogMessageColors lname severity time msg =-    colorizerT severity prefix <> " " <> msg+    colorizer severity prefix <> " " <> msg   where     prefix = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"]") lname severity time     utcTimeF :: Format r (UTCTime -> r)

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

@@ -10,6 +10,7 @@ import           Control.Concurrent         (modifyMVar, modifyMVar_, withMVar) import qualified Data.Text                  as T import qualified Data.Text.IO               as TIO+import           Data.Text.Lazy.Builder     as B import           Formatting                 (sformat, shown, (%)) import           Universum @@ -45,7 +46,7 @@     getFormatter      = rhFormatter     readBack          = rollerReadback -    emit rh (_, msg) _      = rhWriteAction rh (error "Handler is used internally") msg+    emit rh bldr _    = rhWriteAction rh (error "Handler is used internally") (toText . B.toLazyText $ bldr)     close RollerHandler{..} = withMVar rhFileHandle rhCloseAction  data InvalidRotation = InvalidRotation !Text

@@ -26,14 +26,17 @@ import           Control.Concurrent      (modifyMVar_, withMVar) import           Control.Exception       (SomeException) import qualified Data.Text.IO            as TIO+import           Data.Text.Lazy.Builder  as B import           Data.Typeable           (Typeable) import           System.Directory        (createDirectoryIfMissing) import           System.FilePath         (takeDirectory) import           System.IO               (Handle, IOMode (ReadWriteMode),-                                          SeekMode (SeekFromEnd), hClose, hFlush, hSeek)+                                          SeekMode (SeekFromEnd), hClose,+                                          hFlush, hSeek) import           Universum -import           System.Wlog.Formatter   (LogFormatter, nullFormatter, simpleLogFormatter)+import           System.Wlog.Formatter   (LogFormatter, nullFormatter,+                                          simpleLogFormatter) import           System.Wlog.Handler     (LogHandler (..), LogHandlerTag (..)) import           System.Wlog.MemoryQueue (MemoryQueue) import           System.Wlog.MemoryQueue as MQ@@ -57,8 +60,8 @@     getLevel sh = severity sh     setFormatter sh f = sh{formatter = f}     getFormatter sh = formatter sh-    readBack sh i = withMVar (readBackBuffer sh) $ \mq -> pure $! take i (MQ.toList mq)-    emit sh (_,msg) _ = (writeFunc sh) (privData sh) msg+    readBack sh i = withMVar (readBackBuffer sh) $ \mq' -> pure $! take i . MQ.toList $ mq'+    emit sh bldr _ = (writeFunc sh) (privData sh) (toText . B.toLazyText $ bldr)     close sh = (closeFunc sh) (privData sh)  -- | Create a stream log handler. Log messages sent to this handler

@@ -50,22 +50,24 @@ import           Data.Bits                 (shiftL, (.|.)) import qualified Data.Text                 as T import qualified Data.Text.Encoding        as TE+import           Data.Text.Lazy.Builder    as B import           Network.BSD               (getHostByName, hostAddresses)-import           Network.Socket            (Family, Family (..), HostName, PortNumber,-                                            SockAddr (..), Socket,-                                            SocketType (Datagram, Stream), connect,-                                            socket)+import           Network.Socket            (Family, Family (..), HostName,+                                            PortNumber, SockAddr (..), Socket,+                                            SocketType (Datagram, Stream),+                                            connect, socket) import qualified Network.Socket            as S import qualified Network.Socket.ByteString as NBS #ifndef mingw32_HOST_OS import           System.Posix.Process      (getProcessID) #endif-import qualified Data.Text.IO              as TIO+import qualified Data.Text.Lazy.IO         as TIO import           System.IO                 () import           Universum                 hiding (Option, identity)  import           System.Wlog.Formatter     (LogFormatter, varFormatter)-import           System.Wlog.Handler       (LogHandler (..), LogHandlerTag (HandlerOther))+import           System.Wlog.Handler       (LogHandler (..),+                                            LogHandlerTag (HandlerOther)) import           System.Wlog.Severity      (Severity (..))  @@ -257,9 +259,9 @@                           })  syslogFormatter :: LogFormatter SyslogHandler-syslogFormatter sh (p,msg) logname =+syslogFormatter sh lr logname =     let format = "[$loggername/$prio] $msg"-    in varFormatter [] format sh (p,msg) logname+    in varFormatter [] format sh lr logname   instance LogHandler SyslogHandler where@@ -269,11 +271,12 @@     setFormatter sh f = sh{formatter = f}     getFormatter sh = formatter sh     readBack _ _ = pure []-    emit sh (prio, msg) _ = do-      when (elem PERROR (options sh)) (TIO.hPutStrLn stderr msg)+    emit sh bldr _ = do+      when (elem PERROR (options sh)) (TIO.hPutStrLn stderr (B.toLazyText bldr))       pidPart <- getPidPart-      void $ sendstr (toSyslogFormat msg pidPart)+      void $ sendstr (toSyslogFormat (toText $ B.toLazyText bldr) pidPart)       where+        prio = getLevel sh         sendstr :: Text -> IO ()         sendstr t | T.null t = pass         sendstr omsg = do

@@ -70,7 +70,7 @@                                              readBack) import qualified System.Wlog.Handler        (handle) import           System.Wlog.Handler.Simple (streamHandler)-import           System.Wlog.Severity       (LogRecord, Severity (..))+import           System.Wlog.Severity       (LogRecord(..), Severity (..))   ---------------------------------------------------------------------------@@ -220,15 +220,15 @@  -- | Log a message, assuming the current logger's level permits it. logL :: Logger -> Severity -> Text -> IO ()-logL l pri msg = handle l (pri, msg) (const True)+logL l pri msg = handle l (LR pri msg) (const True)  -- | Logs a message with condition. logLCond :: Logger -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO ()-logLCond l pri msg = handle l (pri, msg)+logLCond l pri msg = handle l (LR pri msg)  -- | Handle a log request. handle :: Logger -> LogRecord -> (LogHandlerTag -> Bool) -> IO ()-handle l lrecord@(sev, _) handlerFilter = do+handle l lrecord@(LR sev _) handlerFilter = do     lp <- getLoggerSeverity nm     if sev >= lp then do         ph <- concatMap (view lHandlers) <$> parentLoggers nm

@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BangPatterns #-}  -- | Queue for in-memory logs. Rolls out old logging if size of queue -- is bigger than predefined limit.@@ -10,15 +11,18 @@        , popLast        , pushFront        , toList+       -- * Useful lenses+       , mqMemSize+       , mqLimit        ) where  import           Control.Lens        (to) import           Data.Sequence       (Seq, ViewR (..), viewr, (<|)) import           Universum           hiding (toList) import qualified Universum           as U+import qualified Data.Text           as T -import           Control.Lens        (makeLenses, (%=), (+=))-import           Control.Monad.Loops (whileM_)+import           Control.Lens        (makeLenses)  -- | Class for objects that have size. Implementations can take size -- as amount of memory items take, as amount of items in container,@@ -26,10 +30,11 @@ class Sized e where     getSize :: e -> Word64 --- Instance for text size that takes number of chars in text as size--- (not actual bytes).+-- Instance for text size that pessimistically multiply the number+-- of characters by 16, although the char-varying nature of UTF16+-- means this is greater or equal the true size in bytes. instance Sized Text where-    getSize = fromIntegral . length+    getSize = fromIntegral . (* 16) . T.length  -- | Data structure similar to queue but pops out elements after -- 'pushFront' if 'mqMemSize' > 'mqLimit'.@@ -56,13 +61,20 @@ -- | Add new element at the beginning removing elements from the end -- until size become not greater than limit. pushFront :: (Sized a) => a -> MemoryQueue a -> MemoryQueue a-pushFront msg mq = executingState mq $ do-    mqMemSize += getSize msg-    mqQueue   %= (msg <|)-    whileM_ isLimitExceeded $-        modify (snd . popLast)+pushFront msg oldQueue =+  let msgSize = getSize msg+      newSize = _mqMemSize oldQueue + msgSize+  in resize oldQueue {+      _mqMemSize = newSize+    , _mqQueue   = msg <| _mqQueue oldQueue+    }   where-    isLimitExceeded = liftA2 (<) (use mqLimit) (use mqMemSize)+    -- Resize the queue so that the inner @Seq@ won't contain more than mqLimit+    -- elements.+    resize :: Sized a => MemoryQueue a -> MemoryQueue a+    resize theQueue = case _mqMemSize theQueue > _mqLimit theQueue of+        False -> theQueue+        True  -> let (_, q') = popLast theQueue in resize $! q'  -- | Converts queue to list of messages. toList :: (Sized a) => MemoryQueue a -> [a]

@@ -4,7 +4,7 @@  module System.Wlog.Severity        ( Severity (..)-       , LogRecord+       , LogRecord(..)        ) where  import           Data.SafeCopy (base, deriveSafeCopySimple)@@ -29,4 +29,4 @@ deriveSafeCopySimple 0 'base ''Severity  -- | Internal type of log records.-type LogRecord = (Severity, Text)+data LogRecord = LR !Severity !Text