diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -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 diff --git a/src/System/Wlog/CanLog.hs b/src/System/Wlog/CanLog.hs --- a/src/System/Wlog/CanLog.hs +++ b/src/System/Wlog/CanLog.hs @@ -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 diff --git a/src/System/Wlog/Color.hs b/src/System/Wlog/Color.hs --- a/src/System/Wlog/Color.hs +++ b/src/System/Wlog/Color.hs @@ -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) diff --git a/src/System/Wlog/Formatter.hs b/src/System/Wlog/Formatter.hs --- a/src/System/Wlog/Formatter.hs +++ b/src/System/Wlog/Formatter.hs @@ -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) diff --git a/src/System/Wlog/Handler.hs b/src/System/Wlog/Handler.hs --- a/src/System/Wlog/Handler.hs +++ b/src/System/Wlog/Handler.hs @@ -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 diff --git a/src/System/Wlog/Handler/Roller.hs b/src/System/Wlog/Handler/Roller.hs --- a/src/System/Wlog/Handler/Roller.hs +++ b/src/System/Wlog/Handler/Roller.hs @@ -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 diff --git a/src/System/Wlog/Handler/Simple.hs b/src/System/Wlog/Handler/Simple.hs --- a/src/System/Wlog/Handler/Simple.hs +++ b/src/System/Wlog/Handler/Simple.hs @@ -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 diff --git a/src/System/Wlog/Handler/Syslog.hs b/src/System/Wlog/Handler/Syslog.hs --- a/src/System/Wlog/Handler/Syslog.hs +++ b/src/System/Wlog/Handler/Syslog.hs @@ -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 diff --git a/src/System/Wlog/Logger.hs b/src/System/Wlog/Logger.hs --- a/src/System/Wlog/Logger.hs +++ b/src/System/Wlog/Logger.hs @@ -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 diff --git a/src/System/Wlog/MemoryQueue.hs b/src/System/Wlog/MemoryQueue.hs --- a/src/System/Wlog/MemoryQueue.hs +++ b/src/System/Wlog/MemoryQueue.hs @@ -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] diff --git a/src/System/Wlog/Severity.hs b/src/System/Wlog/Severity.hs --- a/src/System/Wlog/Severity.hs +++ b/src/System/Wlog/Severity.hs @@ -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