monad-effect-logging 0.1.0.0 → 0.3.0.0

raw patch · 8 files changed

+1107/−884 lines, 8 filesdep +optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependencies added: optparse-applicative

API changes (from Hackage documentation)

Files

• README.md +98/−172
• monad-effect-logging.cabal +3/−3
• src/Module/Logging.hs +553/−302
• src/Module/Logging/LogB.hs +0/−114
• src/Module/Logging/LogS.hs +0/−78
• src/Module/Logging/Logger.hs +390/−151
• src/Module/Logging/TraceId.hs +62/−63
• src/Module/Logging/TraceId/XorShiftRNG.hs +1/−1

@@ -1,227 +1,153 @@ # Flexible Logging with Monad-Effect -`monad-effect-logging` is a flexible logging system utilizing the `monad-effect` effect system for Haskell, it gives you very fine control over the logging behavior.--Main features include:+`monad-effect-logging` is a pure structured logging library for the `monad-effect` ecosystem. -* (Optional) Separation of log generation and rendering+The current API is centered on one unified message payload `LogDoc`. -* Pure logging+## Highlights -* Extensible log categories+* You build one `LogDoc` value and decide at the boundary how to render it: -* Compatible with `monad-logger`+  - plain text+  - ANSI colored text+  - different `Show` strategies+  - custom logger pipelines+  +* Color stays semantic until rendering time. A file logger can ignore color while a console logger can emit ANSI codes from the exact same log event. -* `TraceId` support+* Excellent `TraceId` support -## Type Definition+* Open log categories, extensible -```haskell-import qualified Control.Monad.Logger as ML+* Easy JSON logging by tagging `loggerJson` -data Logging m a+This enables you to easily add JSON logging to your files while keeping the console output colorful and readable: you can write no-color json logging to a file while use `pSho` and color constructors to display stuff on the screen at the same time. -instance Module (Logging m (a :: Type)) where-  newtype ModuleRead  (Logging m a) = LoggingRead-    { logging :: Logger m a-    }-  data    ModuleState (Logging m a) = LoggingState+## Core types -data Log a = Log-  { _logType    :: [LogCat]-  , _logContent :: a-  } deriving (Functor)+- `LogEvent` for the event envelope+- `LogWithSourceMeta` for source-location metadata+- `LogDoc` for the structured log message+- `Logger` for the sink+- `LogEffect` for the installed effect -data LogMsg a = LogMsg-  { _logLoc    :: Maybe ML.Loc-  , _logSource :: Maybe ML.LogSource-  , _logMsg    :: a+```haskell+data LogEvent a = LogEvent+  { logEventCats :: [LogCat]+  , logEventPayload :: a   }-``` -A `Logger m a` is just a function that takes a `Log a` and produces an effect in `m ()`.+data LogWithSourceMeta a = LogWithSourceMeta+  { logMetaLoc :: Maybe Loc+  , logMetaSource :: Maybe LogSource+  , logMetaDoc :: a+  } -```haskell-type Logger :: (Type -> Type) -> Type -> Type newtype Logger m a = Logger-  { _runLogger :: Log a -> m ()+  { runLogger :: LogEvent a -> m ()   }-``` -## Features+data LogEffect m a -I developed it by using it and changing it to meet my needs. It solves the following problems:+data LogDoc+``` -### Separation Of Logs and Rendering+The default installed logging effect is: -Sometimes I want to write logs to different files, or sending logs to stdout and files at the same time. I wish I can use the `pretty-simple` pretty print with color in the terminal, but no color in the log files.+```haskell+type Logging = LogEffect IO LogDoc+``` -This means we have to separate log generation and log rendering, we can do exactly that: we provide two default Loggings styles in `Module.Logging.LogS` which uses `Logger m (LogMsg LogStr)` and `Module.Logging.LogB` which uses `Logger m (LogMsg LogBuilder)` (allows you to separate log generation and rendering).+## Building messages -See `Module.Logging.LogB` for relevant functions and types. Here is an example:+String literals work through `IsString`, and deferred values use `logShow`.  ```haskell-import Control.Monad.Effect-import Module.RS import Module.Logging-import Module.Logging.LogB-import Module.Logging.Logger-import Text.Pretty.Simple (pShow, pShowNoColor) -runApp :: EffT '[RModule ProxyState, RModule ProxySettings, LoggingModuleB] NoError IO () -> IO ()-runApp app = do-  opts :: ProxyOptions Unwrapped <- unwrapRecord "Haskell Proxy Server" -- read command line options-  case optionsToSettings opts of-    Nothing -> putStrLn "Invalid options provided."-    Just settings -> do-      baseStdLogger <- useBaseLogger (logWithRendering (renderUsing (toLogStr . pShow)) . simpleLogger True)-        <$> createSimpleConcurrentStdoutBaseLogger-      baseFileLogger <- useBaseLogger (logWithRendering (renderUsing (toLogStr . pShowNoColor)) . simpleLogger True)-        <$> createFileLogger "proxy.log"-      let logger = baseStdLogger <> baseFileLogger :: LoggerWithCleanup IO LogB-      runEffT00 $ withLoggerCleanup logger $ do-        state <- initializeState settings-        runRModule settings $ runRModule state app--main :: IO ()-main = runApp $ do-  activeConnections <- liftIO $ newTVarIO M.empty-  $(logTH Info) "Launching OwO"-  settings <- askR @ProxySettings-  $(logTH Info) $ "Options:" <> logShow settings-  traceId <- liftIO $ newTVarIO (0 :: Word64)-  -- | A Socket is a communication endpoint.-  bracketEffT (liftIO $ socket AF_INET Stream defaultProtocol)-    (\s -> do-      liftIO $ close s-      $(logTH Info) "Main Socket Closed."-      threadIds <- liftIO $ M.elems <$> readTVarIO activeConnections-      forM_ threadIds $ \t -> do-        liftIO $ killThread t-        $(logTH Info) $ "Killed thread: " <> logShow t-    )-    $ \sock -> do-    -- ... Rest of the code+example :: (Monad m, In (LogEffect m LogDoc) mods) => EffT mods es m ()+example = do+  $(logTH Info) $ "starting request " <> logShow (42 :: Int)+  $(logTH Warn) $ logFg Yellow "slow query: " <> toLog ("SELECT ..." :: String) ``` -Those `logShow` does not immediately show anything, they are only rendered when the log is actually written to the output, using the specified rendering function.--### Pure Logging+Useful helpers: -Logging typically works in `IO`, but sometimes I need a complex pure function state machine that outputs diagnostics. It would be great if I don't need to change anything inside the function, using the same logging utilities. The parametrized monad field of the logging effect allows you to use a pure monad (for example writer or state monads) to collect the logs, without needing to change anything inside the function (only need to change how you run it).+- `logRaw`+- `logShow`+- `logFg`+- `logBg`+- `logBold`+- `toLog` -```haskell-eventHandler-  :: (Monad pureMonad)-  => InputEvent-  -> EffT-      [ Logging pureMonad LogData -- ^ We will use logging to generate diagnostics-      , EventState                -- ^ We need to read and update the state-      ]-      [ ErrorText "not-allowed"-      ]-      pureMonad-      [OutputCommands]      -- ^ Output commands from the event module-```+Literal strings can be directly typed in using `IsString` class, no need to convert using helpers. -### Extensible Log Categories+## Rendering and base loggers -You can easily define your own log categories, not just `Debug`, `Info`, `Warn`, `Error`. A log message can have multiple categories, you can add category at anytime using `effAddLogCat`, these types can be used to filter logs later.+Most applications should use one options-based helper from `Module.Logging.Logger`:  ```haskell--- | An exsitential type that wraps all logging categories, it is easy to define a new instance-data LogCat where-  LogCat :: forall sub. IsLogCat sub => sub -> LogCat+import Module.Logging+import Module.Logging.Logger --- | So every module can have its own logging category type, for example--- Database module can have `data Database` used as a log type------ and have a subtype--- @--- data DatabaseSubType = ConnectionPool | Query | Migration | Cursor deriving (Show, Eq)--- @------ you can then write instance------ @--- instance IsLogCat DatabaseSubType where---   severity _    = Nothing---   logTypeDisplay _ = "DB"--- @-class Typeable sub => IsLogCat (sub :: Type) where-  severity :: sub -> Maybe LogSeverity-  severity _ = Nothing-  {-# INLINE severity #-}-  -- | This is used for display only-  logTypeDisplay :: sub -> ML.LogStr-  {-# MINIMAL logTypeDisplay #-}+runApp :: EffT '[LogEffect IO LogDoc] NoError IO () -> IO ()+runApp app = do+  stdoutBase <- createSimpleConcurrentStdoutBaseLogger+  fileBase <- createFileLogger "app.log"++  let stdoutLogger = makeLoggerFromBase ( buildLoggerStyle loggerUseAnsi                ) stdoutBase+  let fileLogger   = makeLoggerFromBase ( buildLoggerStyle (loggerJson . loggerNoStyle) ) fileBase++  runEffT00 $ withLoggerCleanup (stdoutLogger <> fileLogger) app ``` -Here is an example of defining your own log category `ProxyLog`:+Here each style is a builder function `LoggerOptions -> LoggerOptions`, and the `buildLoggerStyle` function is just a composition of them on the `defaultLoggerStyle`. -```haskell-import Module.Logging as L-import Language.Haskell.TH.Syntax (Lift)+For custom pipelines, use the lower-level building blocks: -data ProxyLog = Bytes | Logic deriving (Show, Eq, Lift)-instance IsLogCat ProxyLog where-  severity Bytes = severity L.Debug-  severity Logic = severity L.Info-  logTypeDisplay Bytes = "BYTES"-  logTypeDisplay Logic = "LOGIC"+- `renderLogEvent`+- `loggerFromRenderer`+- your own `Logger`++Styles compose as normal functions:++```haskell+verboseConsole :: LoggerOptions+verboseConsole =+  buildLoggerStyle+    $ loggerUseAnsi+    . loggerOrder [LogTimeChunk, LogCatChunk, LogLocChunk, LogDocChunk] ``` -The `Lift` class is only necessary if you want to use them inside `logTH` template haskell utilities, otherwise you can remove it.+## Categories -To use them, using functions in `Module.Logging.LogS` or `Module.Logging.LogB`, under corresponding logging context:+Categories are open and extensible:  ```haskell-import Module.Logging-import Module.Logging.LogS+data ProxyLog = Bytes | Logic deriving (Lift)+-- The `Lift` class is only necessary if you want to use them inside `logTH` template haskell+-- utilities, otherwise you can remove it. -example :: (In (Logging m LogS) mods, Monad m) => EffT mods es m ()-example = do-  sendBytesToClient 1024-  $(logTH Bytes) "Sent 1024 bytes to client"-  processUserLogin-  $(logTH Logic) "User logged in successfully"+instance IsLogCat ProxyLog where+  severity Bytes = severity Debug+  severity Logic = severity Info+  logTypeName Bytes = "BYTES"+  logTypeName Logic = "LOGIC" ``` -### Compatible With `monad-logger`+You can add local categories with `effAddLogCat`, and filter them with the existing combinators. -You can use all utilities from `monad-logger` inside the `Logging m LogS` effect here since we implement the `MonadLogger` and `MonadLoggerIO` class for it. Although we recommend using the logging utilities provided in `Module.Logging.LogS` and `Module.Logging.LogB`.+## `MonadLogger` compatibility -```haskell-botInstanceToModule :: BotInstance -> EffT '[LoggingModule] NoError IO BotModules-botInstanceToModule bot@(BotInstance runFlag identityFlags commandFlags mode proxyFlags logFlags watchDogFlags _) = do-    $(logInfo) $ "\n### Starting bot instance: " <> tshow bot-    $(logInfo) $ "Running mode: "   <> tshow mode-    $(logInfo) $ "Running flags: "  <> tshow runFlag-    $(logInfo) $ "Identity flags: " <> tshow identityFlags-    $(logInfo) $ "Command flags: "  <> tshow commandFlags-    $(logInfo) $ "Proxy flags: "    <> tshow proxyFlags-    $(logInfo) $ "Log flags: "      <> tshow logFlags-    $(logInfo) $ "WatchDog flags: " <> tshow watchDogFlags-    let mGlobalSysMsg = listToMaybe [ pack sysMsg | UseSysMsg sysMsg <- identityFlags ]-        withDefault def [] = def-        withDefault _ xs = xs-        botModules = BotModules-          { canUseGroupCommands   = withDefault (identifier <$> allGroupCommands)   (coerce commandFlags)-          , canUsePrivateCommands = withDefault (identifier <$> allPrivateCommands) (coerce commandFlags)-          , nameOfBot = BotName $ listToMaybe [ nameBot | UseName nameBot <- identityFlags ]-          , botId = fromMaybe 0 $ listToMaybe [ idBot | UseId idBot <- identityFlags ]-          , globalSysMsg = mGlobalSysMsg-          , proxyTChans = []-          , logFile = [ logFile | LogFlag logFile <- logFlags ]-          , botInstance = bot-          }-    return botModules-```+`MonadLogger` and `MonadLoggerIO` are implemented for `LogEffect m LogDoc`. -### `TraceId` Support+Incoming `monad-logger` messages are wrapped as `logRaw`, so compatibility fits directly into the unified payload model. -In complex applications, it is often useful to trace the flow of a request or operation across multiple log entries. Use `withTraceId` to attach a `TraceId` to a block of codes, all logger inside that block will automatically include the `TraceId` in their log categories.+## `TraceId` -We also included some optional trace id generation utilities.+This library also provides a super convenient `TraceId` mechanism that can attach scoped trace IDs to log events.+`TraceId` is just a log category. Use `withTraceId` or one of the provided generators from `Module.Logging.TraceId`. -See `Module.Logging.TraceId` for relevant functions and types.+## Status++This release presents the library around `LogDoc`, options-based logger construction, open categories, and boundary-driven rendering.

@@ -9,7 +9,7 @@ -- PVP summary:     +-+------- breaking API changes --                  | | +----- non-breaking API additions --                  | | | +--- code changes with no API change-version:            0.1.0.0+version:            0.3.0.0  -- A short (one-line) description of the package. synopsis: A flexible logging system utilizing the `monad-effect` effect system.@@ -54,8 +54,6 @@      -- Modules exported by the library.     exposed-modules: Module.Logging-                   , Module.Logging.LogS-                   , Module.Logging.LogB                    , Module.Logging.Logger                    , Module.Logging.TraceId     ghc-options: -fexpose-all-unfoldings@@ -79,6 +77,7 @@                  , template-haskell >= 2.20 && < 2.24                  , primitive < 0.10                  , clock < 0.9+                 , optparse-applicative < 0.20      -- Directories containing source files.     hs-source-dirs:   src@@ -94,3 +93,4 @@                       , LambdaCase                       , TypeFamilies                       , TypeApplications+                      , TypeAbstractions

@@ -1,33 +1,59 @@-{-# LANGUAGE TemplateHaskell, UndecidableInstances, AllowAmbiguousTypes, DeriveLift, OverloadedRecordDot #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-}--- | We want a logger that supports open categories, open levels, open severities etc.--- so that we can filter on different levels for different categories------ finally we will also provide an interface for MonadLogger for compatibility+ module Module.Logging-  ( -- * Definitions+  ( -- * Core Types     LogSeverity   , IsLogCat(..)   , LogCat(..)-  , Log(..), logType, logContent-  , LogMsg(..), logLoc, logSource, logMsg-  , Logger(..), runLogger+  , someSeverity+  , someLogCatName+  , someLogCatDisplay+    -- * Log Event Model+  , LogEvent(..)+  , logEventCats+  , logEventPayload+  , LogWithSourceMeta(..)+  , logMetaLoc+  , logMetaSource+  , logMetaDoc+  , Logger(..)+  , runLogger+  , LogEffect   , Logging   , LoggingModule-  -- * Default log categories+    -- * Structured Log Documents+  , LogDoc+  , SomeShown+  , NamedColor(..)+  , Color(..)+  , Style(..)+  , defaultStyle+  , StyleMode(..)+  , DocRenderOptions(..)+  , defaultDocRenderOptions+  , renderLogDoc+  , logRaw+  , logShow+  , logFg+  , logBg+  , logBold+  , ToLog(..)+    -- * Default Log Categories   , Debug(..)   , Info(..)   , Warn(..)   , Error(..)   , Other(..)-  -- * Default log implementation-  , toLogStrS-  , logLog-  , LogS-  , LogData-  -- * Combinators+    -- * Logger Combinators   , localLogger-  , localLog+  , localLogEvent   , addLogCat   , effAddLogCat   , effAddLogCat'@@ -39,402 +65,627 @@   , isLogCat   , isLogSubType   , isLogCatName-  , someSeverity-  , someLogCatName-  -- * Running and initializing-  , runLogging+  , liftLogger+    -- * Logging Operations+  , emitLogEvent+  , log_+  , logLoc_+  , logs+  , logTH+  , logLocIO+  , logIO+  , logsIO+  , logTHIO+    -- * Running and Initialization+  , runLogEffect   , withLiftLogger-  -- * Other optional utilities   , defaultStringToLogSeverity-  , defaultLoggingFromEnv-  , defaultLoggingFromArgs+    -- * Compatibility   , monadLoggerAdapter   , mlLogLevelToLogCat--  -- * Re-export+    -- * Re-exports   , ModuleRead(..)   , ModuleState(..)   , ModuleInitData(..)   , ModuleEvent(..)-  -- * Re-export contravariant functors   , module Data.Functor.Contravariant   ) where  import Control.Applicative import Control.Lens-import Control.System import Control.Monad import Control.Monad.Effect-import Control.Monad.Logger (Loc(..))+import Control.System import Data.Fixed import Data.Functor.Contravariant import Data.Kind+import Data.List (intercalate) import Data.Maybe+import Data.String (IsString(..)) import Data.Text (Text) import Data.Typeable-import qualified Control.Monad.Logger as ML--import System.Environment+import Data.Word import Text.Read (readMaybe)-+import qualified Control.Monad.Logger as ML+import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH --- | so user can interpolate between levels easily------ by default, Debug = 1, Info = 2, Warn = 3, Error = 4--- you can use anything in between, with a precision of 1 decimal place--- for example, 2.5 is between Info and Warn type LogSeverity = Fixed E1 --- | So every module can have its own logging category type, for example--- Database module can have `data Database` used as a log type------ and have a subtype--- @--- data DatabaseSubType = ConnectionPool | Query | Migration | Cursor deriving (Show, Eq)--- @------ you can then write instance------ @--- instance IsLogCat DatabaseSubType where---   severity _    = Nothing---   logTypeDisplay _ = "DB"--- @-class Typeable sub => IsLogCat (sub :: Type) where-  severity :: sub -> Maybe LogSeverity+class Typeable cat => IsLogCat (cat :: Type) where+  severity :: cat -> Maybe LogSeverity   severity _ = Nothing-  {-# INLINE severity #-}-  -- | This is used for display only-  logTypeDisplay :: sub -> ML.LogStr-  {-# MINIMAL logTypeDisplay #-} -instance IsLogCat Text where-  logTypeDisplay = ML.toLogStr+  logTypeName :: cat -> ML.LogStr+  {-# MINIMAL logTypeName #-}++  logTypeDisplay :: ML.LogStr -> LogDoc+  logTypeDisplay = DocRaw   {-# INLINE logTypeDisplay #-} --- | An exsitential type that wraps all logging categories, it is easy to define a new instance+instance IsLogCat Text where+  logTypeName = ML.toLogStr+ data LogCat where-  LogCat :: forall sub. IsLogCat sub => sub -> LogCat+  LogCat :: forall cat. IsLogCat cat => cat -> LogCat  someSeverity :: LogCat -> Maybe LogSeverity-someSeverity (LogCat @a subType) = severity @a subType-{-# INLINE someSeverity #-}+someSeverity (LogCat @cat x) = severity @cat x  someLogCatName :: LogCat -> ML.LogStr-someLogCatName (LogCat @a subType) = logTypeDisplay @a subType-{-# INLINE someLogCatName #-}+someLogCatName (LogCat @cat x) = logTypeName @cat x -data Log a = Log-  { _logType    :: [LogCat]-  , _logContent :: a-  } deriving (Functor)+someLogCatDisplay :: LogCat -> LogDoc+someLogCatDisplay (LogCat @cat x) = logTypeDisplay @cat (logTypeName @cat x) -type LogS = LogMsg ML.LogStr+-- | Carries several log categories and a payload.+data LogEvent a = LogEvent+  { _logEventCats    :: [LogCat]+  , _logEventPayload :: a+  }+  deriving (Functor) -type LogData = LogS-{-# DEPRECATED LogData "Use LogS instead" #-}+data LogWithSourceMeta a = LogWithSourceMeta+  { _logMetaLoc    :: Maybe ML.Loc+  , _logMetaSource :: Maybe ML.LogSource+  , _logMetaDoc    :: a+  }+  deriving (Functor) -data LogMsg a = LogMsg-  { _logLoc    :: Maybe ML.Loc-  , _logSource :: Maybe ML.LogSource-  , _logMsg    :: a+data SomeShown where+  SomeShown :: Show a => a -> SomeShown++data NamedColor+  = Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  deriving (Eq, Show)++data Color+  = DefaultColor+  | Named !NamedColor+  | RGB   !Word8 !Word8 !Word8+  deriving (Eq, Show)++class IsLogColor c where+  toLogColor :: c -> Color++instance IsLogColor Color where+  toLogColor = id++instance IsLogColor NamedColor where+  toLogColor = Named++instance IsLogColor (Word8, Word8, Word8) where+  toLogColor (r, g, b) = RGB r g b++class ToLog a where+  toLog :: a -> LogDoc++instance ToLog LogDoc where+  toLog = id++instance ToLog Text where+  toLog = DocRaw . ML.toLogStr++instance ToLog String where+  toLog = DocRaw . ML.toLogStr++data Style = Style+  { styleFg   :: Maybe Color+  , styleBg   :: Maybe Color+  , styleBold :: Bool   }+  deriving (Eq, Show) -makeLenses ''Log-makeLenses ''LogMsg-makeLenses ''Loc+defaultStyle :: Style+defaultStyle =+  Style+    { styleFg   = Nothing+    , styleBg   = Nothing+    , styleBold = False+    } -instance Functor LogMsg where-  fmap f logMsg' = logMsg' { _logMsg = f (_logMsg logMsg') }-  {-# INLINE fmap #-}+data LogDoc+  = DocEmpty+  | DocRaw    ML.LogStr+  | DocShown  SomeShown+  | DocStyled Style  LogDoc+  | DocAppend LogDoc LogDoc -instance Semigroup a => Semigroup (LogMsg a) where-  l1 <> l2 = LogMsg-    { _logLoc = l1 ^. logLoc <|> l2 ^. logLoc-    , _logSource = l1 ^. logSource <|> l2 ^. logSource-    , _logMsg = l1 ^. logMsg <> l2 ^. logMsg+data StyleMode+  = NoStyles+  | AnsiStyles+  deriving (Eq, Show)++data DocRenderOptions = DocRenderOptions+  { docRenderShow      :: forall a. Show a => a -> ML.LogStr+  , docRenderStyleMode :: StyleMode+  }++defaultDocRenderOptions :: DocRenderOptions+defaultDocRenderOptions =+  DocRenderOptions+    { docRenderShow      = ML.toLogStr . show+    , docRenderStyleMode = NoStyles     }-  {-# INLINE (<>) #-} -instance Monoid a => Monoid (LogMsg a) where-  mempty = LogMsg Nothing Nothing mempty-  {-# INLINE mempty #-}+makeLenses ''LogEvent+makeLenses ''LogWithSourceMeta --- | Some default log types, you can easily define your own-data    Debug = Debug  deriving TH.Lift-data    Info  = Info   deriving TH.Lift-data    Warn  = Warn   deriving TH.Lift-data    Error = Error  deriving TH.Lift-newtype Other = Other Text  deriving TH.Lift+instance Semigroup a => Semigroup (LogEvent a) where+  LogEvent catsA payloadA <> LogEvent catsB payloadB =+    LogEvent (catsA <> catsB) (payloadA <> payloadB) -instance IsLogCat Debug where severity _ = Just 1; logTypeDisplay _ = "DEBUG"-instance IsLogCat Info  where severity _ = Just 2; logTypeDisplay _ = "INFO"-instance IsLogCat Warn  where severity _ = Just 3; logTypeDisplay _ = "WARN"-instance IsLogCat Error where severity _ = Just 4; logTypeDisplay _ = "ERROR"-instance IsLogCat Other where-  severity _ = Just 2-  logTypeDisplay (Other t) = "OTHER:" <> ML.toLogStr t+instance Monoid a => Monoid (LogEvent a) where+  mempty = LogEvent [] mempty -instance Semigroup a => Semigroup (Log a) where-  Log t1 c1 <> Log t2 c2 = Log (t1 <> t2) (c1 <> c2)-  {-# INLINE (<>) #-}+instance Applicative LogEvent where+  pure = LogEvent []+  LogEvent catsF f <*> LogEvent catsA a = LogEvent (catsF <> catsA) (f a) -instance Monoid a => Monoid (Log a) where-  mempty = Log [] mempty-  {-# INLINE mempty #-}+instance Monad LogEvent where+  LogEvent catsA a >>= f =+    let LogEvent catsB b = f a+     in LogEvent (catsA <> catsB) b -instance Applicative Log where-  pure = Log []-  {-# INLINE pure #-}-  Log t1 f <*> Log t2 a = Log (t1 <> t2) (f a)-  {-# INLINE (<*>) #-}+instance Semigroup a => Semigroup (LogWithSourceMeta a) where+  metaA <> metaB =+    LogWithSourceMeta+      { _logMetaLoc    = _logMetaLoc    metaA <|> _logMetaLoc    metaB+      , _logMetaSource = _logMetaSource metaA <|> _logMetaSource metaB+      , _logMetaDoc    = _logMetaDoc    metaA <>  _logMetaDoc    metaB+      } -instance Monad Log where-  (Log t a) >>= f =-    let Log t' a' = f a-    in Log (t <> t') a'-  {-# INLINE (>>=) #-}+instance Monoid a => Monoid (LogWithSourceMeta a) where+  mempty = LogWithSourceMeta Nothing Nothing mempty +instance IsString LogDoc where+  fromString = DocRaw . ML.toLogStr++instance Semigroup LogDoc where+  (<>) = DocAppend++instance Monoid LogDoc where+  mempty = DocEmpty++data Debug    = Debug      deriving TH.Lift+data Info     = Info       deriving TH.Lift+data Warn     = Warn       deriving TH.Lift+data Error    = Error      deriving TH.Lift+newtype Other = Other Text deriving TH.Lift++instance IsLogCat Debug where+  severity _ = Just 1+  logTypeName _ = "DEBUG"+  logTypeDisplay = logFg Blue . DocRaw++instance IsLogCat Info where+  severity _ = Just 2+  logTypeName _ = "INFO"+  logTypeDisplay = logFg Green . DocRaw++instance IsLogCat Warn where+  severity _ = Just 3+  logTypeName _ = "WARN"+  logTypeDisplay = logFg Yellow . DocRaw++instance IsLogCat Error where+  severity _ = Just 4+  logTypeName _ = "ERROR"+  logTypeDisplay = logFg Red . DocRaw++instance IsLogCat Other where+  severity _ = Just 2+  logTypeName (Other t) = "OTHER:" <> ML.toLogStr t+ type Logger :: (Type -> Type) -> Type -> Type newtype Logger m a = Logger-  { _runLogger :: Log a -> m ()+  { _runLogger :: LogEvent a -> m ()   } -liftLogger :: (m () -> n ()) -> Logger m b -> Logger n b-liftLogger f (Logger g) = Logger (f . g)-{-# INLINE liftLogger #-}+runLogger :: Logger m a -> LogEvent a -> m ()+runLogger = _runLogger -makeLenses ''Logger+liftLogger :: (m () -> n ()) -> Logger m a -> Logger n a+liftLogger nat (Logger f) = Logger (nat . f)  instance Applicative m => Semigroup (Logger m a) where-  Logger f <> Logger g = Logger $ \log' -> f log' *> g log'-  {-# INLINE (<>) #-}+  Logger f <> Logger g = Logger $ \entry -> f entry *> g entry  instance Applicative m => Monoid (Logger m a) where   mempty = Logger $ const $ pure ()-  {-# INLINE mempty #-}  instance Contravariant (Logger m) where   contramap f (Logger g) = Logger (g . fmap f)-  {-# INLINE contramap #-} ------------------------------------------------------------------------------------ $ Some combinators for logger filtering------ You can use these combinators to filter logs based on their types and severities.--- Example:------ @--- localLogger---   ( anyLogCat (severityThat $ Predicate (>= 1))---   . excludeLogCat (isLogCat @Database)---   ) $ do---     ...--- @+logRaw :: ML.LogStr -> LogDoc+logRaw = DocRaw --- | Locally modify the logger-localLogger :: forall a c m mods es b. (Monad m, In' c (Logging m a) mods) => (Logger m a -> Logger m a) -> EffT' c mods es m b -> EffT' c mods es m b-localLogger f = localModule (\(LoggingRead logger) -> LoggingRead (f logger))-{-# INLINE localLogger #-}+logShow :: Show a => a -> LogDoc+logShow = DocShown . SomeShown --- | Locally modify the log-localLog :: forall a m mods es c. (Monad m, Logging m a `In` mods) => (Log a -> Log a) -> EffT mods es m c -> EffT mods es m c-localLog f = localLogger $ over runLogger (. f)-{-# INLINE localLog #-}+logFg :: IsLogColor color => color -> LogDoc -> LogDoc+logFg color = DocStyled defaultStyle {styleFg = Just $ toLogColor color} --- | Add a log category to the log--- @--- localLogger (addLogCat $ LogCat ConnectionPool) $ do---   ...--- @+logBg :: IsLogColor color => color -> LogDoc -> LogDoc+logBg color = DocStyled defaultStyle {styleBg = Just $ toLogColor color}++logBold :: LogDoc -> LogDoc+logBold = DocStyled defaultStyle {styleBold = True}++renderLogDoc :: DocRenderOptions -> LogDoc -> ML.LogStr+renderLogDoc opts = case docRenderStyleMode opts of+  NoStyles -> goPlain+  AnsiStyles -> goAnsi defaultStyle+  where+    goPlain DocEmpty                 = mempty+    goPlain (DocRaw str)             = str+    goPlain (DocShown (SomeShown x)) = docRenderShow opts x+    goPlain (DocStyled _ doc)        = goPlain doc+    goPlain (DocAppend a b)          = goPlain a <> goPlain b++    goAnsi _       DocEmpty                 = mempty+    goAnsi _       (DocRaw str)             = str+    goAnsi _       (DocShown (SomeShown x)) = docRenderShow opts x+    goAnsi current (DocAppend a b)          = goAnsi current a <> goAnsi current b+    goAnsi current (DocStyled style doc)    =+      let merged = mergeStyle current style+       in ansiForStyle merged <> goAnsi merged doc <> ansiForStyle current++mergeStyle :: Style -> Style -> Style+mergeStyle outer inner =+  Style+    { styleFg   = styleFg   inner <|> styleFg   outer+    , styleBg   = styleBg   inner <|> styleBg   outer+    , styleBold = styleBold outer ||  styleBold inner+    }++ansiForStyle :: Style -> ML.LogStr+ansiForStyle style =+  ML.toLogStr $ "\ESC[" <> mconcat (intercalate [";"] (pure <$> codes)) <> "m"+  where+    codes =+      let baseCodes =+            concat+              [ maybe [] colorToFgCodes (styleFg style)+              , maybe [] colorToBgCodes (styleBg style)+              , ["1" | styleBold style]+              ]+       in if null baseCodes then ["0"] else baseCodes++colorToFgCodes :: Color -> [ML.LogStr]+colorToFgCodes DefaultColor  = ["39"]+colorToFgCodes (Named color) = [lshow $ namedColorCode color]+colorToFgCodes (RGB r g b)   = ["38", "2", lshow r, lshow g, lshow b]++colorToBgCodes :: Color -> [ML.LogStr]+colorToBgCodes DefaultColor  = ["49"]+colorToBgCodes (Named color) = [lshow $ namedColorCode color + 10]+colorToBgCodes (RGB r g b)   = ["48", "2", lshow r, lshow g, lshow b]++lshow :: Show a => a -> ML.LogStr+lshow = ML.toLogStr . show+{-# INLINE lshow #-}++namedColorCode :: NamedColor -> Int+namedColorCode = \case+  Black   -> 30+  Red     -> 31+  Green   -> 32+  Yellow  -> 33+  Blue    -> 34+  Magenta -> 35+  Cyan    -> 36+  White   -> 37++localLogger+  :: forall a c m mods es b.+     (Monad m, In' c (LogEffect m a) mods)+  => (Logger m (LogWithSourceMeta a) -> Logger m (LogWithSourceMeta a))+  -> EffT' c mods es m b+  -> EffT' c mods es m b+localLogger f =+  localModule (\(LogEffectRead logger) -> LogEffectRead (f logger))++localLogEvent+  :: forall a m mods es c.+     (Monad m, LogEffect m a `In` mods)+  => (LogEvent (LogWithSourceMeta a) -> LogEvent (LogWithSourceMeta a))+  -> EffT mods es m c+  -> EffT mods es m c+localLogEvent f = localLogger $ \(Logger g) -> Logger (g . f)+ addLogCat :: LogCat -> Logger m a -> Logger m a-addLogCat t = over runLogger (. over logType (t:))-{-# INLINE addLogCat #-}+addLogCat cat (Logger g) =+  Logger $ \entry -> g entry {_logEventCats = cat : _logEventCats entry} --- | Add a log category to the log in EffT--- @--- effAddLogCat @LogS (LogCat ConnectionPool) $ do---   ...--- @-effAddLogCat :: forall a c mods es m b. (Monad m, In' c (Logging m a) mods) => LogCat -> EffT' c mods es m b -> EffT' c mods es m b-effAddLogCat logCat = localLogger @a (addLogCat logCat)-{-# INLINE effAddLogCat #-}+effAddLogCat+  :: forall a c mods es m b.+     (Monad m, In' c (LogEffect m a) mods)+  => LogCat+  -> EffT' c mods es m b+  -> EffT' c mods es m b+effAddLogCat cat = localLogger @a (addLogCat cat) --- | Add a log category to the log in EffT (defaulting to In (Logging m LogS) mods)--- @--- effAddLogCat' (LogCat ConnectionPool) $ do---   ...--- @-effAddLogCat' :: forall c mods es m b. (Monad m, In' c (Logging m LogS) mods) => LogCat -> EffT' c mods es m b -> EffT' c mods es m b-effAddLogCat' logCat = localLogger @LogS (addLogCat logCat)-{-# INLINE effAddLogCat' #-}+effAddLogCat'+  :: forall c mods es m b.+     (Monad m, In' c (LogEffect m LogDoc) mods)+  => LogCat+  -> EffT' c mods es m b+  -> EffT' c mods es m b+effAddLogCat' = effAddLogCat @LogDoc  filterLogCats :: Applicative m => Predicate [LogCat] -> Logger m a -> Logger m a-filterLogCats p (Logger logger) = Logger $ \log' -> when (p.getPredicate $ log' ^. logType) $ logger log'-{-# INLINE filterLogCats #-}+filterLogCats p (Logger logger) =+  Logger $ \entry ->+    when (getPredicate p $ _logEventCats entry) $+      logger entry  anyLogCat :: Applicative m => Predicate LogCat -> Logger m a -> Logger m a-anyLogCat p = filterLogCats (Predicate $ any p.getPredicate)-{-# INLINE anyLogCat #-}+anyLogCat p = filterLogCats (Predicate $ any (getPredicate p))  excludeLogCat :: Applicative m => Predicate LogCat -> Logger m a -> Logger m a-excludeLogCat p = filterLogCats (Predicate $ not . any p.getPredicate)-{-# INLINE excludeLogCat #-}+excludeLogCat p = filterLogCats (Predicate $ not . any (getPredicate p))  severityThat :: Predicate LogSeverity -> Predicate LogCat severityThat = contramap (fromMaybe 0 . someSeverity)-{-# INLINE severityThat #-}  noSeverity :: Predicate LogCat noSeverity = Predicate (isNothing . someSeverity)-{-# INLINE noSeverity #-} --- | use type applications to check if a log type is present-isLogCat :: forall sub. IsLogCat sub => Predicate LogCat-isLogCat = Predicate $ \(LogCat (_ :: sub')) -> case eqT @sub @sub' of-  Just Refl -> True-  Nothing   -> False-{-# INLINE isLogCat #-}+-- | Use with type applications+isLogCat :: forall cat. IsLogCat cat => Predicate LogCat+isLogCat =+  Predicate $ \(LogCat (_ :: cat')) -> case eqT @cat @cat' of+    Just Refl -> True+    Nothing -> False -isLogSubType :: forall sub. IsLogCat sub => Predicate sub -> Predicate LogCat-isLogSubType p = Predicate $ \(LogCat (subType :: sub')) -> case eqT @sub @sub' of-  Just Refl -> p.getPredicate subType-  Nothing   -> False-{-# INLINE isLogSubType #-}+isLogSubType :: forall cat. IsLogCat cat => Predicate cat -> Predicate LogCat+isLogSubType p =+  Predicate $ \(LogCat (x :: cat')) -> case eqT @cat @cat' of+    Just Refl -> getPredicate p x+    Nothing -> False  isLogCatName :: ML.ToLogStr n => n -> Predicate LogCat-isLogCatName name = Predicate $ \logCat -> someLogCatName logCat == ML.toLogStr name-{-# INLINE isLogCatName #-}+isLogCatName name =+  Predicate $ \logCat -> someLogCatName logCat == ML.toLogStr name --- | The Logging m module type, a module `Logging m a` provides logging capabilities for logs of type `a`-type Logging :: (Type -> Type) -> Type -> Type-data Logging m a+type LogEffect :: (Type -> Type) -> Type -> Type+data LogEffect m a -type LoggingModule = Logging IO LogS -- standard logging module+type Logging = LogEffect +type LoggingModule = LogEffect IO LogDoc+ withLiftLogger   :: forall m n c a mods es b.-  ( Monad m-  , In' c (Logging m a) (Logging m a : mods)-  , ConsFDataList c (Logging n a : mods)-  , ConsFDataList c (Logging m a : mods)-  )-  => (forall x. m x -> n x) -> EffT' c (Logging n a : mods) es m b -> EffT' c (Logging m a : mods) es m b+     ( Monad m+     , In' c (LogEffect m a) (LogEffect m a : mods)+     , ConsFDataList c (LogEffect n a : mods)+     , ConsFDataList c (LogEffect m a : mods)+     )+  => (forall x. m x -> n x)+  -> EffT' c (LogEffect n a : mods) es m b+  -> EffT' c (LogEffect m a : mods) es m b withLiftLogger lifter act = do-  LoggingRead logger <- askModule @(Logging m a)-  let logger' = liftLogger lifter logger-  embedMods $ runEffTOuter_ (LoggingRead logger') LoggingState act+  LogEffectRead logger <- askModule @(LogEffect m a)+  embedMods $ runEffTOuter_ (LogEffectRead $ liftLogger lifter logger) LogEffectState act -instance Module (Logging m (a :: Type)) where-  newtype ModuleRead  (Logging m a) = LoggingRead-    { logging :: Logger m a+instance Module (LogEffect m a) where+  newtype ModuleRead (LogEffect m a) = LogEffectRead+    { logging :: Logger m (LogWithSourceMeta a)     }-  data    ModuleState (Logging m a) = LoggingState+  data ModuleState (LogEffect m a) = LogEffectState -runLogging-  :: (ConsFDataList c (Logging m logS : mods), Monad m) => Logger m logS-  -> EffT' c (Logging m logS : mods) es m a-  -> EffT' c mods es m a-runLogging logger = runEffTOuter_ (LoggingRead logger) LoggingState-{-# INLINE runLogging #-}+runLogEffect+  :: (ConsFDataList c (LogEffect m a : mods), Monad m)+  => Logger m (LogWithSourceMeta a)+  -> EffT' c (LogEffect m a : mods) es m b+  -> EffT' c mods es m b+runLogEffect logger = runEffTOuter_ (LogEffectRead logger) LogEffectState -instance SystemModule (Logging m a) where-  data    ModuleInitData (Logging m a) = LoggingInitData-    { loggerInitLogger   :: Logger IO a-    , loggerInitSeverity :: Maybe LogSeverity-    , loggerInitCleanup  :: Maybe (IO ())+instance SystemModule (LogEffect m a) where+  data ModuleInitData (LogEffect m a) = LogEffectInitData+    { loggerInitBase       :: Logger m (LogWithSourceMeta a)+    , loggerInitCleanup    :: Maybe (m ())+    , loggerInitTransform  :: Logger m (LogWithSourceMeta a) -> Logger m (LogWithSourceMeta a)+    , loggerInitSeverity   :: Maybe LogSeverity     }-  data    ModuleEvent    (Logging m a) = LoggingEvent+  data ModuleEvent (LogEffect m a) = LogEffectEvent -instance Loadable c (Logging IO a) mods ies where-  withModule (LoggingInitData logger mSev Nothing) act = case mSev of-    Nothing -> runEffTOuter_ (LoggingRead logger) LoggingState act-    Just s -> runEffTOuter_ (LoggingRead $ anyLogCat (severityThat $ Predicate (>= s)) logger) LoggingState act-  withModule (LoggingInitData logger mSev (Just clean)) act = bracketEffT (return ()) (\_ -> liftIO clean) (\_ -> case mSev of-      Nothing -> runEffTOuter_ (LoggingRead logger) LoggingState act-      Just s -> runEffTOuter_ (LoggingRead $ anyLogCat (severityThat $ Predicate (>= s)) logger) LoggingState act-    )-  {-# INLINE withModule #-}+instance Loadable c (LogEffect IO a) mods ies where+  withModule initData act =+    let transformedLogger = loggerInitTransform initData (loggerInitBase initData)+        baseLogger = case loggerInitSeverity initData of+          Nothing -> transformedLogger+          Just sev ->+            anyLogCat (severityThat $ Predicate (>= sev)) transformedLogger+        runAction = runEffTOuter_ (LogEffectRead baseLogger) LogEffectState act+     in case loggerInitCleanup initData of+          Nothing -> runAction+          Just cleanup -> bracketEffT (pure ()) (\_ -> liftIO cleanup) (const runAction) -instance EventLoop c (Logging m a) mods es+instance EventLoop c (LogEffect m a) mods es --- | Maps 'Debug', 'Info', 'Warn', 'Error' to 1, 2, 3, 4 respectively--- and also accepts numbers between 0 and 10 with a precision of 1 decimal place+emitLogEvent+  :: forall a c mods es m.+     (Monad m, In' c (LogEffect m a) mods)+  => LogEvent (LogWithSourceMeta a)+  -> EffT' c mods es m ()+emitLogEvent entry = do+  action <- asksModule @(LogEffect m a) (runLogger . logging)+  lift $ action entry++logLoc_+  :: forall c mods es m cat.+     (Monad m, In' c (LogEffect m LogDoc) mods, IsLogCat cat)+  => ML.Loc+  -> cat+  -> LogDoc+  -> EffT' c mods es m ()+logLoc_ loc cat doc =+  emitLogEvent $+    LogEvent+      { _logEventCats = [LogCat cat]+      , _logEventPayload =+          LogWithSourceMeta+            { _logMetaLoc    = Just loc+            , _logMetaSource = Nothing+            , _logMetaDoc    = doc+            }+      }++log_+  :: forall c mods es m cat.+     (Monad m, In' c (LogEffect m LogDoc) mods, IsLogCat cat)+  => cat+  -> LogDoc+  -> EffT' c mods es m ()+log_ cat doc =+  emitLogEvent $+    LogEvent+      { _logEventCats = [LogCat cat]+      , _logEventPayload =+          LogWithSourceMeta+            { _logMetaLoc    = Nothing+            , _logMetaSource = Nothing+            , _logMetaDoc    = doc+            }+      }++logs+  :: forall c mods es m.+     (Monad m, In' c (LogEffect m LogDoc) mods)+  => [LogCat]+  -> LogDoc+  -> EffT' c mods es m ()+logs cats doc =+  emitLogEvent $+    LogEvent+      { _logEventCats = cats+      , _logEventPayload =+          LogWithSourceMeta+            { _logMetaLoc    = Nothing+            , _logMetaSource = Nothing+            , _logMetaDoc    = doc+            }+      }++logTH :: (IsLogCat cat, TH.Lift cat) => cat -> TH.Q TH.Exp+logTH cat = [| logLoc_ $(TH.qLocation >>= TH.lift) $(TH.lift cat) |]++logLocIO+  :: forall c mods es m cat.+     (MonadIO m, In' c (LogEffect IO LogDoc) mods, IsLogCat cat)+  => ML.Loc+  -> cat+  -> LogDoc+  -> EffT' c mods es m ()+logLocIO loc cat = baseTransform liftIO . logLoc_ loc cat++logIO+  :: forall c mods es m cat.+     (MonadIO m, In' c (LogEffect IO LogDoc) mods, IsLogCat cat)+  => cat+  -> LogDoc+  -> EffT' c mods es m ()+logIO cat = baseTransform liftIO . log_ cat++logsIO+  :: forall c mods es m.+     (MonadIO m, In' c (LogEffect IO LogDoc) mods)+  => [LogCat]+  -> LogDoc+  -> EffT' c mods es m ()+logsIO cats = baseTransform liftIO . logs cats++logTHIO :: (IsLogCat cat, TH.Lift cat) => cat -> TH.Q TH.Exp+logTHIO cat = [| baseTransform liftIO . logLoc_ @LogDoc $(TH.qLocation >>= TH.lift) $(TH.lift cat) |]+ defaultStringToLogSeverity :: String -> Either Text LogSeverity defaultStringToLogSeverity = \case   "Debug" -> Right 1   "Info"  -> Right 2   "Warn"  -> Right 3   "Error" -> Right 4-  other   -> maybe (Left "Invalid LogLevel, must be one of 'Debug', 'Info', 'Warn', 'Error', or a number between 0 and 10 with a precision of 1 decimal place") Right-    $ readMaybe other-{-# INLINABLE defaultStringToLogSeverity #-}---- | Load a log level from environment variable LOG_LEVEL,-defaultLoggingFromEnv :: Logger IO LogS -> Maybe (IO ()) -> IO (ModuleInitData LoggingModule)-defaultLoggingFromEnv logger mcl = do-  mLogLevel <- liftIO $ (readMaybe =<<) <$> lookupEnv "LOG_LEVEL"-  return $ LoggingInitData logger mLogLevel mcl-{-# INLINABLE defaultLoggingFromEnv #-}---- | Load an argument --log-level <level> from command line arguments,--- if none is provided, it will log everything (Maybe LogSeverity = Nothing)-defaultLoggingFromArgs :: Logger IO LogS -> Maybe (IO ()) -> [String] -> Either Text (ModuleInitData LoggingModule)-defaultLoggingFromArgs logger mcl []         = Right $ LoggingInitData logger Nothing mcl-defaultLoggingFromArgs logger mcl args@(_:_) = do-  level    <- maybe (Right Nothing) (fmap Just) $ detectFlag "--log-level" defaultStringToLogSeverity args-  types    <- sequence $ detectAllFlags "--log-type"    (\case "" -> Left "Empty log type"; s -> Right s) args-  nonTypes <- sequence $ detectAllFlags "--no-log-type" (\case "" -> Left "Empty log type"; s -> Right s) args-  let logger' = foldr ($) logger (  [ anyLogCat     (isLogCatName name) | name <- types ]-                                 <> [ excludeLogCat (isLogCatName name) | name <- nonTypes ]-                                 )-  return $ LoggingInitData logger' level mcl-{-# INLINABLE defaultLoggingFromArgs #-}+  other ->+    maybe+      (Left "Invalid LogLevel, must be one of 'Debug', 'Info', 'Warn', 'Error', or a number between 0 and 10 with a precision of 1 decimal place")+      Right+      (readMaybe other) -monadLoggerAdapter :: Logger m LogS -> ML.Loc -> ML.LogSource -> ML.LogLevel -> ML.LogStr -> m ()-monadLoggerAdapter logger loc src lev msg = _runLogger logger Log-  { _logType = [mlLogLevelToLogCat lev]-  , _logContent = LogMsg-      { _logLoc    = Just loc-      , _logSource = Just src-      , _logMsg    = msg+monadLoggerAdapter+  :: Logger m (LogWithSourceMeta LogDoc)+  -> ML.Loc+  -> ML.LogSource+  -> ML.LogLevel+  -> ML.LogStr+  -> m ()+monadLoggerAdapter logger loc src lev msg =+  runLogger logger $+    LogEvent+      { _logEventCats = [mlLogLevelToLogCat lev]+      , _logEventPayload =+          LogWithSourceMeta+            { _logMetaLoc    = Just loc+            , _logMetaSource = Just src+            , _logMetaDoc    = logRaw msg+            }       }-  }-{-# INLINE monadLoggerAdapter #-} --- | This provides an interface to MonadLogger-instance (Monad m, In' c (Logging m LogS) mods) => ML.MonadLogger (EffT' c mods es m) where-  monadLoggerLog loc logsource loglevel msg = do-    LoggingRead logger <- queryModule @(Logging m LogS)-    lift $ monadLoggerAdapter logger loc logsource loglevel (ML.toLogStr msg)-  {-# INLINE monadLoggerLog #-}+instance (Monad m, In' c (LogEffect m LogDoc) mods) => ML.MonadLogger (EffT' c mods es m) where+  monadLoggerLog loc src lev msg = do+    LogEffectRead logger <- queryModule @(LogEffect m LogDoc)+    lift $ monadLoggerAdapter logger loc src lev (ML.toLogStr msg) -instance (m ~ IO, In' c (Logging m LogS) mods) => ML.MonadLoggerIO (EffT' c mods es m) where-  askLoggerIO = queriesModule @(Logging m LogS) $ (\f loc src lev str -> f-    $ Log [mlLogLevelToLogCat lev]-    $ LogMsg-      { _logLoc    = Just loc-      , _logSource = Just src-      , _logMsg    = str-      }-    ) . _runLogger . logging-  {-# INLINE askLoggerIO #-}+instance (m ~ IO, In' c (LogEffect m LogDoc) mods) => ML.MonadLoggerIO (EffT' c mods es m) where+  askLoggerIO =+    queriesModule @(LogEffect m LogDoc) $+      (\f loc src lev str ->+         f $+           LogEvent+             { _logEventCats = [mlLogLevelToLogCat lev]+             , _logEventPayload =+                 LogWithSourceMeta+                   { _logMetaLoc    = Just loc+                   , _logMetaSource = Just src+                   , _logMetaDoc    = logRaw str+                   }+             }+      )+        . runLogger+        . logging --- | A compatibility function that works for the old MonadLogger instances mlLogLevelToLogCat :: ML.LogLevel -> LogCat-mlLogLevelToLogCat ML.LevelDebug     = LogCat Debug-mlLogLevelToLogCat ML.LevelInfo      = LogCat Info-mlLogLevelToLogCat ML.LevelWarn      = LogCat Warn-mlLogLevelToLogCat ML.LevelError     = LogCat Error-mlLogLevelToLogCat (ML.LevelOther t) = LogCat (Other t)-{-# INLINE mlLogLevelToLogCat #-}--logLog :: forall a c mods es m. (Monad m, In' c (Logging m a) mods) => Log a -> EffT' c mods es m ()-logLog logd = asksModule @(Logging m a) (_runLogger . logging) >>= (\action -> lift $ action logd)-{-# INLINABLE logLog #-}---- | Apply 'show' to convert a value to LogStr-toLogStrS :: Show a => a -> ML.LogStr-toLogStrS = ML.toLogStr . show-{-# INLINE toLogStrS #-}+mlLogLevelToLogCat = \case+  ML.LevelDebug   -> LogCat Debug+  ML.LevelInfo    -> LogCat Info+  ML.LevelWarn    -> LogCat Warn+  ML.LevelError   -> LogCat Error+  ML.LevelOther t -> LogCat (Other t)

@@ -1,114 +0,0 @@--- | Module      : Module.Logging.LogVal---   Description : Log value builders and renderers. This module provides a way to build log messages separately from rendering them, allowing for flexible logging rendering strategies (e.g. with console colors, JSON formatting, etc.).-{-# LANGUAGE TemplateHaskell #-}-module Module.Logging.LogB-  ( -- * Log value builders and renderers-    LogVals-  , LogBuilder-  , LogRenderer-  , toLog-  , logShow-  , renderUsing--  -- * Logging module types-  , LogB-  , LoggingModuleB-  -- * General logging utilities-  , log_-  , logLoc_-  , logs-  , logTH-  -- * MonadIO specific versions-  , logLocIO-  , logIO-  , logsIO-  , logTHIO-  ) where--import Data.String (IsString(..))-import qualified Control.Monad.Logger as ML-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH-import Module.Logging-import Control.Monad.Effect-import Control.Lens---- | Note on LogStr from monad-logger:---   It is just Data.ByteString.Builder.Builder, but with extra length information for buffering.-data LogVal where-  LogValStr :: ML.LogStr   -> LogVal-  LogShow   :: Show a => a -> LogVal--type LogVals = [LogVal]--type LogBuilder   = LogVals    -> LogVals-type LogRenderer  = LogBuilder -> ML.LogStr--instance IsString LogVal where-  fromString = LogValStr . fromString-  {-# INLINE fromString #-}--instance IsString LogBuilder where-  fromString s = (LogValStr (fromString s) :)-  {-# INLINE fromString #-}-instance {-# OVERLAPPING #-} Semigroup LogBuilder where-  (<>) = (.)-  {-# INLINE (<>) #-}-instance {-# OVERLAPPING #-} Monoid LogBuilder where-  mempty = id-  {-# INLINE mempty #-}---- | Use this function together with OverloadedStrings and <> to log your messages-logShow :: Show a => a -> LogBuilder-logShow v = (LogShow v :)-{-# INLINE logShow #-}--renderUsing :: (forall a. Show a => a -> ML.LogStr) -> LogRenderer-renderUsing func vals = mconcat @ML.LogStr $ map renderVal (vals [])-  where renderVal (LogValStr ls) = ls-        renderVal (LogShow   v ) = func v--type LogB = LogMsg LogBuilder--type LoggingModuleB = Logging IO LogB--toLog :: (ML.ToLogStr a) => a -> LogBuilder-toLog = (:) . LogValStr . ML.toLogStr-{-# INLINE toLog #-}--logLoc_ :: (Monad m, In' c (Logging m LogB) mods, IsLogCat subType) => ML.Loc -> subType -> LogBuilder -> EffT' c mods es m ()-logLoc_ src subTypeType msg = logLog (Log [LogCat subTypeType] (mempty @LogB & logMsg .~ msg & logLoc ?~ src))-{-# INLINE logLoc_ #-}---- | Simple logging function, provide one log type and a LogStr message-log_ :: (Monad m, In' c (Logging m LogB) mods, IsLogCat subType) => subType -> LogBuilder -> EffT' c mods es m ()-log_ subTypeType msg = logLog (Log [LogCat subTypeType] (mempty @LogB & logMsg .~ msg))-{-# INLINE log_ #-}---- | Log with multiple log types (wrapped in existantial constructor LogCat)-logs :: (Monad m, In' c (Logging m LogB) mods) => [LogCat] -> LogBuilder -> EffT' c mods es m ()-logs logTypes msg = logLog (Log logTypes (mempty @LogB & logMsg .~ msg))-{-# INLINE logs #-}---- | Template Haskell helper with location info-logTH :: (IsLogCat subType, TH.Lift subType) => subType -> TH.Q TH.Exp-logTH subType = [| logLoc_ $(TH.qLocation >>= TH.lift) $(TH.lift subType) |]------------ Monad IO specific versions ------------ -- | Useful when you are in a MonadIO but with a Logging IO _ type module-logLocIO :: (MonadIO m, In' c (Logging IO LogB) mods, IsLogCat subType) => ML.Loc -> subType -> LogBuilder -> EffT' c mods es m ()-logLocIO src subTypeType = baseTransform liftIO . logLoc_ src subTypeType-{-# INLINE logLocIO #-}--logIO :: (MonadIO m, In' c (Logging IO LogB) mods, IsLogCat subType) => subType -> LogBuilder -> EffT' c mods es m ()-logIO subTypeType = baseTransform liftIO . log_ subTypeType-{-# INLINE logIO #-}--logsIO :: (MonadIO m, In' c (Logging IO LogB) mods) => [LogCat] -> LogBuilder -> EffT' c mods es m ()-logsIO logTypes = baseTransform liftIO . logs logTypes-{-# INLINE logsIO #-}---- | Template Haskell helper with location info, with m=IO-logTHIO :: (IsLogCat subType, TH.Lift subType) => subType -> TH.Q TH.Exp-logTHIO subType = [| baseTransform liftIO . logLoc_ $(TH.qLocation >>= TH.lift) $(TH.lift subType) |]

@@ -1,78 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Module.Logging.LogS-  (-  -- * Log value builders and renderers-    toLog-  , logShow-  -- * Logging module types-  , LogS-  , LoggingModule-  -- * General logging utilities-  , log_-  , logLoc_-  , logs-  , logTH-  , logS-  -- * MonadIO specific versions-  , logLocIO-  , logIO-  , logsIO-  , logTHIO-  -- * Re-export-  , ML.LogStr-  ) where--import qualified Control.Monad.Logger as ML-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Syntax as TH-import Module.Logging-import Control.Monad.Effect-import Control.Lens--toLog :: (ML.ToLogStr a) => a -> ML.LogStr-toLog = ML.toLogStr-{-# INLINE toLog #-}--logShow :: Show a => a -> ML.LogStr-logShow = ML.toLogStr . show-{-# INLINE logShow #-}--logS :: (Monad m, In' c (Logging m LogS) mods) => LogS -> EffT' c mods es m ()-logS logd = logLog (Log [] logd)-{-# INLINE logS #-}--logLoc_ :: (Monad m, In' c (Logging m LogS) mods, IsLogCat subType) => ML.Loc -> subType -> ML.LogStr -> EffT' c mods es m ()-logLoc_ src subTypeType msg = logLog (Log [LogCat subTypeType] (mempty @LogS & logMsg .~ msg & logLoc ?~ src))-{-# INLINE logLoc_ #-}---- | Simple logging function, provide one log type and a LogStr message-log_ :: (Monad m, In' c (Logging m LogS) mods, IsLogCat subType) => subType -> ML.LogStr -> EffT' c mods es m ()-log_ subTypeType msg = logLog (Log [LogCat subTypeType] (mempty @LogS & logMsg .~ msg))-{-# INLINE log_ #-}---- | Log with multiple log types (wrapped in existantial constructor LogCat)-logs :: (Monad m, In' c (Logging m LogS) mods) => [LogCat] -> ML.LogStr -> EffT' c mods es m ()-logs logTypes msg = logLog (Log logTypes (mempty @LogS & logMsg .~ msg))-{-# INLINE logs #-}---- | Template Haskell helper with location info-logTH :: (IsLogCat subType, TH.Lift subType) => subType -> TH.Q TH.Exp-logTH subType = [| logLoc_ $(TH.qLocation >>= TH.lift) $(TH.lift subType) |]------------ Monad IO specific versions ------------logLocIO :: (MonadIO m, In' c (Logging IO LogS) mods, IsLogCat subType) => ML.Loc -> subType -> ML.LogStr -> EffT' c mods es m ()-logLocIO src subTypeType = baseTransform liftIO . logLoc_ src subTypeType-{-# INLINE logLocIO #-}--logIO :: (MonadIO m, In' c (Logging IO LogS) mods, IsLogCat subType) => subType -> ML.LogStr -> EffT' c mods es m ()-logIO subTypeType = baseTransform liftIO . log_ subTypeType-{-# INLINE logIO #-}--logsIO :: (MonadIO m, In' c (Logging IO LogS) mods) => [LogCat] -> ML.LogStr -> EffT' c mods es m ()-logsIO logTypes = baseTransform liftIO . logs logTypes-{-# INLINE logsIO #-}---- | Template Haskell helper with location info, with MonadIO-logTHIO :: (IsLogCat subType, TH.Lift subType) => subType -> TH.Q TH.Exp-logTHIO subType = [| baseTransform liftIO . logLoc_ @IO $(TH.qLocation >>= TH.lift) $(TH.lift subType) |]

@@ -1,200 +1,439 @@-{-# LANGUAGE RecordWildCards, DuplicateRecordFields #-}--- | Some simple combinators to build your logger+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ApplicativeDo         #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE OverloadedRecordDot   #-}+ module Module.Logging.Logger-  ( module Module.Logging.Logger-  -- * Re-exporting fast-logger+  ( -- * Logger Lifecycle+    LoggerWithCleanup(..)+  , liftBaseLogger+    -- * Logger Options+  , LoggerOptions(..)+  , LogOrderControl(..)+  , LoggerStyle+  , defaultLoggerStyle+  , buildLoggerStyle+  , loggerUseAnsi+  , loggerNoStyle+  , loggerShowWith+  , loggerNoTime+  , loggerNoCats+  , loggerNoLoc+  , loggerNoSource+  , loggerNoNewline+  , loggerJson+  , loggerOrder+    -- * Base Loggers+  , createFastBaseLogger+  , createStdoutBaseLogger+  , createSimpleStdoutBaseLogger+  , createSimpleConcurrentStdoutBaseLogger+  , createStderrBaseLogger+  , createFileLogger+  , createFileLoggerWith+    -- * Rendering and Composition+  , renderLogEvent+  , loggerFromRenderer+  , makeLoggerFromBase+  , withLoggerCleanup+  , withBaseLogger+  , withBaseLoggerIO+    -- * Helpers+  , defaultLoggingFromEnv+  , defaultLoggingFromArgs+  , defaultLoggingOptParser+    -- * Re-exporting fast-logger   , module System.Log.FastLogger   ) where -import Control.Monad import Control.Concurrent import Control.Concurrent.STM+import Control.Exception (bracket)+import Control.Lens ((^.))+import Control.Monad import Control.Monad.Effect+import Control.System (detectFlag, detectAllFlags)+import Data.Text (Text) import Data.Time.Clock import Module.Logging+import System.Environment (lookupEnv) import System.Log.FastLogger-import System.Log.FastLogger.Internal (LogStr (..))+import System.Log.FastLogger.Internal (LogStr(..))+import Text.Read (readMaybe) import qualified Control.Monad.Logger as ML import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import Data.List (foldl1')-import Control.Exception (bracket)+import qualified Options.Applicative as O+import Data.Maybe+import Data.List (intersperse)+import Control.Arrow+import Data.Word+import Data.ByteString (ByteString)+import qualified Data.ByteString as B --- | Logger with a cleanup function-data LoggerWithCleanup m log = LoggerWithCleanup-  { baseLogFunc :: log -> m ()+data LoggerWithCleanup m a = LoggerWithCleanup+  { baseLogFunc :: a -> m ()   , cleanUpFunc :: m ()   } -useBaseLogger :: ((LogStr -> m ()) -> Logger m logS) -> LoggerWithCleanup m LogStr -> LoggerWithCleanup m (Log logS)-useBaseLogger makeLogger (LoggerWithCleanup logFunc cleanUp) =-  LoggerWithCleanup (_runLogger $ makeLogger logFunc) cleanUp-{-# INLINE useBaseLogger #-}+data LogOrderControl+  = LogTimeChunk+  | LogCatChunk+  | LogLocChunk+  | LogSrcChunk+  | LogDocChunk+  deriving (Eq, Ord, Show) --- | Primitive version of 'useBaseLogger'-useBaseLogger' :: Monad m => (Log logS -> m LogStr) -> LoggerWithCleanup m LogStr -> LoggerWithCleanup m (Log logS)-useBaseLogger' makeLogger (LoggerWithCleanup logFunc cleanUp) =-  LoggerWithCleanup (makeLogger >=> logFunc) cleanUp-{-# INLINE useBaseLogger' #-}+data LoggerOptions = LoggerOptions+  { loggerDocRenderOptions :: DocRenderOptions+  , loggerIncludeTime      :: Bool+  , loggerIncludeCats      :: Bool+  , loggerIncludeLoc       :: Bool+  , loggerIncludeSource    :: Bool+  , loggerAppendNewline    :: Bool+  , loggerJsonFormat       :: Bool+  , loggerOrderControl     :: Maybe [LogOrderControl]+  } -liftBaseLogger :: (m () -> n ()) -> LoggerWithCleanup m log -> LoggerWithCleanup n log-liftBaseLogger nat (LoggerWithCleanup f c) = LoggerWithCleanup (nat . f) (nat c)-{-# INLINE liftBaseLogger #-}+type LoggerStyle = LoggerOptions -> LoggerOptions -instance Applicative m => Semigroup (LoggerWithCleanup m log) where-  (LoggerWithCleanup l1 c1) <> (LoggerWithCleanup l2 c2) = LoggerWithCleanup (\l -> l1 l *> l2 l) (c1 *> c2)-  {-# INLINE (<>) #-}-instance Applicative m => Monoid (LoggerWithCleanup m log) where+defaultLoggerStyle :: LoggerOptions+defaultLoggerStyle =+  LoggerOptions+    { loggerDocRenderOptions = defaultDocRenderOptions+    , loggerIncludeTime      = True+    , loggerIncludeCats      = True+    , loggerIncludeLoc       = True+    , loggerIncludeSource    = True+    , loggerAppendNewline    = True+    , loggerJsonFormat       = False+    , loggerOrderControl     = Nothing+    }++buildLoggerStyle :: LoggerStyle -> LoggerOptions+buildLoggerStyle style = style defaultLoggerStyle++loggerUseAnsi :: LoggerStyle+loggerUseAnsi opts =+  opts+    { loggerDocRenderOptions =+        (loggerDocRenderOptions opts) { docRenderStyleMode = AnsiStyles }+    }++loggerNoStyle :: LoggerStyle+loggerNoStyle opts =+  opts+    { loggerDocRenderOptions =+        (loggerDocRenderOptions opts) { docRenderStyleMode = NoStyles }+    }++loggerShowWith :: (forall a. Show a => a -> ML.LogStr) -> LoggerStyle+loggerShowWith renderShown opts =+  opts+    { loggerDocRenderOptions =+        (loggerDocRenderOptions opts) { docRenderShow = renderShown }+    }++loggerNoTime :: LoggerStyle+loggerNoTime opts = opts {loggerIncludeTime = False}++loggerNoCats :: LoggerStyle+loggerNoCats opts = opts {loggerIncludeCats = False}++loggerNoLoc :: LoggerStyle+loggerNoLoc opts = opts {loggerIncludeLoc = False}++loggerNoSource :: LoggerStyle+loggerNoSource opts = opts {loggerIncludeSource = False}++loggerNoNewline :: LoggerStyle+loggerNoNewline opts = opts {loggerAppendNewline = False}++loggerJson :: LoggerStyle+loggerJson opts = opts {loggerJsonFormat = True}++loggerOrder :: [LogOrderControl] -> LoggerStyle+loggerOrder chunks opts = opts {loggerOrderControl = Just chunks}++liftBaseLogger :: (m () -> n ()) -> LoggerWithCleanup m a -> LoggerWithCleanup n a+liftBaseLogger nat (LoggerWithCleanup f cleanup) =+  LoggerWithCleanup (nat . f) (nat cleanup)++instance Applicative m => Semigroup (LoggerWithCleanup m a) where+  LoggerWithCleanup logA cleanA <> LoggerWithCleanup logB cleanB =+    LoggerWithCleanup (\entry -> logA entry *> logB entry) (cleanA *> cleanB)++instance Applicative m => Monoid (LoggerWithCleanup m a) where   mempty = LoggerWithCleanup (const $ pure ()) (pure ())-  {-# INLINE mempty #-} --- | It doesn't mean it is really fast, called 'FastBaseLogger' because it is imported from fast-logger createFastBaseLogger :: MonadIO m => LogType -> m (LoggerWithCleanup IO LogStr)-createFastBaseLogger logT = liftIO $ uncurry LoggerWithCleanup <$> newFastLogger logT+createFastBaseLogger logType =+  liftIO $ uncurry LoggerWithCleanup <$> newFastLogger logType --- | Uses the logger from fast-logger with default buffer-size createStdoutBaseLogger :: MonadIO m => m (LoggerWithCleanup IO LogStr) createStdoutBaseLogger = createFastBaseLogger (LogStdout defaultBufSize) --- | A very simple logger that just prints to stdout **without buffering**.--- Inlines a putStr function. Suitable for simple applications createSimpleStdoutBaseLogger :: MonadIO m => m (LoggerWithCleanup IO LogStr)-createSimpleStdoutBaseLogger = liftIO $ do-  let logFunc (LogStr _ builder) = BL.putStr (BB.toLazyByteString builder)-  return $ LoggerWithCleanup logFunc (return ())-{-# INLINE createSimpleStdoutBaseLogger #-}+createSimpleStdoutBaseLogger =+  liftIO $ do+    let logFunc (LogStr _ builder) = BL.putStr (BB.toLazyByteString builder)+    pure $ LoggerWithCleanup logFunc (pure ()) --- | A very simple concurrent logger that just prints to stdout **without buffering**.--- A cleanUp function is provided to make sure all logs are printed before exiting. createSimpleConcurrentStdoutBaseLogger :: MonadIO m => m (LoggerWithCleanup IO LogStr)-createSimpleConcurrentStdoutBaseLogger = liftIO $ do-  queue <- newTQueueIO-  counter <- newTVarIO (0 :: Int)-  -- ^ the caller increments this when logging atomically-  -- logger checks this to see if it should exit-  let logFunc (LogStr _ builder) = do-        atomically $ do-          writeTQueue queue builder-          modifyTVar' counter (+1)-      rawLogFunc builder = BL.putStr (BB.toLazyByteString builder)-      atomicLogFunc queue' = do-        logStr <- atomically $ do-          logStr <- readTQueue queue'-          modifyTVar' counter (subtract 1)-          return logStr-        rawLogFunc logStr-  let cleanUpFunc = do-        remQ <- atomically $ do-          r <- readTVar counter-          if r == 0-            then return Nothing-            else do-              b <- flushTQueue queue-              writeTVar counter 0-              return (Just b)-        forM_ remQ (mapM_ rawLogFunc)-  _ <- forkIO $ forever $ atomicLogFunc queue-  return $ LoggerWithCleanup logFunc cleanUpFunc+createSimpleConcurrentStdoutBaseLogger =+  liftIO $ do+    queue <- newTQueueIO+    counter <- newTVarIO (0 :: Int)+    let logFunc (LogStr _ builder) =+          atomically $ do+            writeTQueue queue builder+            modifyTVar' counter (+ 1)+        rawLogFunc builder = BL.putStr (BB.toLazyByteString builder)+        atomicLogFunc queue' = do+          builder <- atomically $ do+            next <- readTQueue queue'+            modifyTVar' counter (subtract 1)+            pure next+          rawLogFunc builder+        cleanUpFunc tid = do+          killThread tid+          remaining <- atomically $ do+            count <- readTVar counter+            if count == 0+              then pure Nothing+              else do+                builders <- flushTQueue queue+                writeTVar counter 0+                pure (Just builders)+          forM_ remaining (mapM_ rawLogFunc)+    tid <- forkIO $ forever $ atomicLogFunc queue+    pure $ LoggerWithCleanup logFunc (cleanUpFunc tid) --- | Uses the logger from fast-logger with default buffer-size createStderrBaseLogger :: MonadIO m => m (LoggerWithCleanup IO LogStr) createStderrBaseLogger = createFastBaseLogger (LogStderr defaultBufSize) --- | Uses the logger from fast-logger with default buffer-size createFileLogger :: MonadIO m => FilePath -> m (LoggerWithCleanup IO LogStr)-createFileLogger fp = createFastBaseLogger (LogFile (FileLogSpec fp (512 * 1024 * 1024) 3) defaultBufSize)+createFileLogger fp =+  createFastBaseLogger (LogFile (FileLogSpec fp (256 * 1024 * 1024) 2) defaultBufSize) -type Timed = Bool--- | this formats the logging data and sends it to the provided function-simpleLogger :: MonadIO m => Timed -> (LogStr -> m ()) -> Logger m LogS-simpleLogger time-  = contramap logSimple-  . contramap (<> "\n")-  . (if time then timeLogger else id)-  . typedLogger-  . baseToLogger+createFileLoggerWith :: MonadIO m => Integer -> Int -> FilePath -> m (LoggerWithCleanup IO LogStr)+createFileLoggerWith size count fp =+  createFastBaseLogger (LogFile (FileLogSpec fp size count) defaultBufSize) --- | Render the inner data type into LogStr and pass to the provided logger accepting LogStr.--- @--- logWithRendering renderB = contramap $ fmap renderB--- @------ Example:--- @--- logWithRendering someRenderFunc (simpleLogger False baseLogFunc) :: Logger m (LogMsg b)--- @-logWithRendering :: (b -> LogStr) -> Logger m LogS -> Logger m (LogMsg b)-logWithRendering renderB = contramap $ fmap renderB-{-# INLINE logWithRendering #-}+renderLogEvent :: LoggerOptions -> LogEvent (LogWithSourceMeta LogDoc) -> IO ML.LogStr+renderLogEvent LoggerOptions {..} entry = do+  let meta = entry ^. logEventPayload+      docChunk = renderLogDoc loggerDocRenderOptions (meta ^. logMetaDoc)+      catChunk =+        if loggerIncludeCats && not (null (entry ^. logEventCats))+          then squareBracket $ logSepList (map (renderLogDoc loggerDocRenderOptions . someLogCatDisplay) (entry ^. logEventCats))+          else emptyField+      locChunk =+        if loggerIncludeLoc+          then maybe emptyField renderLoc (meta ^. logMetaLoc)+          else emptyField+      srcChunk =+        if loggerIncludeSource+          then maybe emptyField ML.toLogStr (meta ^. logMetaSource)+          else emptyField+      suffix = if loggerAppendNewline then "\n" else mempty+      orderControl = fromMaybe [LogTimeChunk, LogCatChunk, LogLocChunk, LogSrcChunk, LogDocChunk] loggerOrderControl --- | simply apply the provided function to the log string-baseToLogger :: (LogStr -> m ()) -> Logger m LogStr-baseToLogger baseIO = Logger $ \(Log _ str) -> baseIO str-{-# INLINE baseToLogger #-}+      logSepList x = mconcat (intersperse sep $ map quote x) --- | Modifies LogStr: add the types of the log to the log string on the left-typedLogger :: Logger m LogStr -> Logger m LogStr-typedLogger (Logger logFunc) = Logger $ \(Log types logStr) -> do-  let typeNames = map someLogCatName types-  let logLine-        | null typeNames = logStr-        | otherwise = "[" <> foldl1' (\x y -> x <> "|" <> y) typeNames <> "] " <> logStr-  logFunc $ Log types logLine-{-# INLINE typedLogger #-}+      emptyField+        | loggerJsonFormat = "null"+        | otherwise        = mempty --- | add the current time to the log string on the left-timeLogger :: MonadIO m => Logger m LogStr -> Logger m LogStr-timeLogger (Logger logger) = Logger $ \(Log types logStr) -> do-  time <- liftIO getCurrentTime-  let timeStr = toLogStr (show time)-  logger $ Log types (timeStr <> "|" <> logStr)-{-# INLINE timeLogger #-}+      quote x = "\"" <> x <> "\"" --- | format the log data into a simple log string, utilizing log types, and location info (if any)-logSimple :: LogS -> LogStr-logSimple LogMsg {..}-    =  maybe "" ((<> ",") . toLogStr . ML.loc_filename) _logLoc-    <> maybe "" ((<> "-") . displayPos . ML.loc_start) _logLoc-    <> maybe "" ((<> "|") . displayPos . ML.loc_end) _logLoc-    <> maybe "" ((<> "|") . toLogStr) _logSource-    <> _logMsg-  where displayPos (l, c) = toLogStr (show l <> ":" <> show c)-{-# INLINE logSimple #-}+      quoteAndEscape x = quote (escape x) --- | Bracket pattern, runs the action with the provided logger and cleans up afterwards+      escape :: ML.LogStr -> ML.LogStr+      escape+        =   fromLogStr+        >>> replace+              [ (wordQuote    , B.pack [wordBackslash, wordQuote     ])+              , (wordBackslash, B.pack [wordBackslash, wordBackslash ])+              , (wordNewline  , B.pack [wordBackslash, wordN         ])+              , (wordTab      , B.pack [wordBackslash, wordT         ])+              , (wordCarriage , B.pack [wordBackslash, wordR         ])+              ]+        >>> map toLogStr+        >>> mconcat+        where+          wordQuote     = 34  :: Word8+          wordBackslash = 92  :: Word8+          wordNewline   = 10  :: Word8+          wordTab       = 9   :: Word8+          wordCarriage  = 13  :: Word8+          wordN         = 110 :: Word8+          wordT         = 116 :: Word8+          wordR         = 114 :: Word8++      replace :: [(Word8, ByteString)] -> ByteString -> [ByteString]+      replace works input =+        let (prefix, work) = B.break (\c -> any (\(w, _) -> w == c) works) input+        in case B.uncons work of+          Nothing     -> [prefix]+          Just (h, t) ->+            prefix+            : case lookup h works of+                Nothing -> B.singleton h+                Just r  -> r+            : replace works t++      squareBracket x = "[" <> x <> "]"++      bigBracket x = "{" <> x <> "}"++      ifJson :: (a -> a) -> a -> a+      ifJson f x = if loggerJsonFormat then f x else x++      sep = if loggerJsonFormat then "," else "|"++      renderLoc loc =+        objectLike+          [ ("file" , ifJson quote $ ML.toLogStr (ML.loc_filename loc))+          , ("start", ifJson quote $ displayPos (ML.loc_start loc))+          , ("end"  , ifJson quote $ displayPos (ML.loc_end loc))+          ]++      objectLike :: [(ML.LogStr, ML.LogStr)] -> ML.LogStr+      objectLike  = ifJson bigBracket+                  . mconcat+                  . intersperse sep+                  . map (\(k, v) -> ifJson ((quote k <> ":") <>) v)++      displayPos (line, col) = ML.toLogStr (show line <> ":" <> show col)++  timeChunk <-+    if loggerIncludeTime+      then ML.toLogStr . show <$> getCurrentTime+      else pure mempty+  pure $ objectLike (map (\case+           LogTimeChunk -> ("time", ifJson quote timeChunk)+           LogCatChunk  -> ("type", catChunk)+           LogLocChunk  -> ("loc" , locChunk)+           LogSrcChunk  -> ("src" , srcChunk)+           LogDocChunk  -> ("doc" , ifJson quoteAndEscape docChunk)+         ) orderControl) <> suffix++loggerFromRenderer+  :: MonadIO m+  => LoggerOptions+  -> (ML.LogStr -> m ())+  -> Logger m (LogWithSourceMeta LogDoc)+loggerFromRenderer opts sink =+  Logger $ \entry -> do+    rendered <- liftIO $ renderLogEvent opts entry+    sink rendered++makeLoggerFromBase+  :: MonadIO m+  => LoggerOptions+  -> LoggerWithCleanup m ML.LogStr+  -> LoggerWithCleanup m (LogEvent (LogWithSourceMeta LogDoc))+makeLoggerFromBase opts LoggerWithCleanup {..} =+  LoggerWithCleanup+    { baseLogFunc = runLogger (loggerFromRenderer opts baseLogFunc)+    , cleanUpFunc = cleanUpFunc+    }+ withLoggerCleanup-  :: (ConsFDataList c (Logging m logS : mods), Monad m, MonadMask m)-  => LoggerWithCleanup m (Log logS) -- ^ specify a logger with cleanup function-  -> EffT' c (Logging m logS : mods) es m a-  -> EffT' c mods es m a-withLoggerCleanup (LoggerWithCleanup logger cleanUp) action = bracketEffT-  (return ())-  (\_ -> lift cleanUp)-  (\_ -> runLogging (Logger logger) action)-{-# INLINE withLoggerCleanup #-}+  :: (ConsFDataList c (LogEffect m a : mods), Monad m, MonadMask m)+  => LoggerWithCleanup m (LogEvent (LogWithSourceMeta a))+  -> EffT' c (LogEffect m a : mods) es m b+  -> EffT' c mods es m b+withLoggerCleanup (LoggerWithCleanup logger cleanup) action =+  bracketEffT+    (pure ())+    (\_ -> lift cleanup)+    (\_ -> runLogEffect (Logger logger) action) --- $ Bracket pattern--- | This function is used to create a logger in a scoped manner.--- It takes care of creating and cleaning up the base logger. withBaseLogger-  :: (ConsFDataList c (Logging m (LogMsg logS) : mods), Monad m, MonadMask m)-  => m (LoggerWithCleanup m LogStr)               -- ^ specify a base logger-  -> ((LogStr -> m ()) -> Logger m (LogMsg logS)) -- ^ specify how to format the log data using the base logger-  -> EffT' c (Logging m (LogMsg logS) : mods) es m a+  :: (ConsFDataList c (LogEffect m LogDoc : mods), MonadIO m, MonadMask m)+  => m (LoggerWithCleanup m ML.LogStr)+  -> LoggerOptions+  -> EffT' c (LogEffect m LogDoc : mods) es m a   -> EffT' c mods es m a-withBaseLogger createBaseLogger makeLogger action = bracketEffT-  (lift createBaseLogger)-  (\LoggerWithCleanup {cleanUpFunc} -> lift cleanUpFunc)-  (\LoggerWithCleanup {baseLogFunc} -> runLogging (makeLogger baseLogFunc) action)-{-# INLINE withBaseLogger #-}+withBaseLogger createBaseLogger opts action =+  bracketEffT+    (lift createBaseLogger)+    (\LoggerWithCleanup {cleanUpFunc} -> lift cleanUpFunc)+    (\baseLogger ->+       let logger = Logger (baseLogFunc (makeLoggerFromBase opts baseLogger))+        in runLogEffect logger action+    )  withBaseLoggerIO-  :: IO (LoggerWithCleanup IO LogStr)                    -- ^ specify a base logger-  -> ((LogStr -> IO ()) -> Logger IO logS) -- ^ specify how to log logS using the base logger-  -> (Logger IO logS -> IO a)  -- ^ action to run with the logger+  :: IO (LoggerWithCleanup IO ML.LogStr)+  -> LoggerOptions+  -> (Logger IO (LogWithSourceMeta LogDoc) -> IO a)   -> IO a-withBaseLoggerIO createBaseLogger makeLogger action = bracket-  (liftIO createBaseLogger)-  (\LoggerWithCleanup {cleanUpFunc} -> liftIO cleanUpFunc)-  (\LoggerWithCleanup {baseLogFunc} -> action (makeLogger baseLogFunc))-{-# INLINE withBaseLoggerIO #-}+withBaseLoggerIO createBaseLogger opts action =+  bracket+    createBaseLogger+    cleanUpFunc+    (\baseLogger -> action $ loggerFromRenderer opts baseLogger.baseLogFunc)++----++defaultLoggingFromEnv+  :: LoggerWithCleanup IO (LogEvent (LogWithSourceMeta LogDoc))+  -> IO (ModuleInitData LoggingModule)+defaultLoggingFromEnv (LoggerWithCleanup logger cleanup) = do+  mLevel <- (readMaybe =<<) <$> lookupEnv "LOG_LEVEL"+  pure $ LogEffectInitData (Logger logger) (Just cleanup) id mLevel++defaultLoggingFromArgs+  :: LoggerWithCleanup IO (LogEvent (LogWithSourceMeta LogDoc))+  -> [String]+  -> Either Text (ModuleInitData LoggingModule)+defaultLoggingFromArgs (LoggerWithCleanup logger cleanup) [] =+  Right $ LogEffectInitData (Logger logger) (Just cleanup) id Nothing+defaultLoggingFromArgs (LoggerWithCleanup logger cleanup) args = do+  level <- maybe (Right Nothing) (fmap Just) $ detectFlag "--log-level" defaultStringToLogSeverity args+  types <- sequence $ detectAllFlags "--log-type" (\case "" -> Left "Empty log type"; s -> Right s) args+  nonTypes <- sequence $ detectAllFlags "--no-log-type" (\case "" -> Left "Empty log type"; s -> Right s) args+  let transform =+        foldr+          (.)+          id+          ( [anyLogCat (isLogCatName name) | name <- types]+              <> [excludeLogCat (isLogCatName name) | name <- nonTypes]+          )+  pure $ LogEffectInitData (Logger logger) (Just cleanup) transform level++defaultLoggingOptParser+  :: Applicative m+  => LoggerWithCleanup m (LogEvent (LogWithSourceMeta LogDoc))+  -> O.Parser (ModuleInitData (LogEffect m LogDoc))+defaultLoggingOptParser (LoggerWithCleanup logger cleanup) = do+  level <-+    O.optional $+      O.option O.auto+        ( O.long "log-level"+            <> O.metavar "LEVEL"+            <> O.help "Log level, one of 'Debug', 'Info', 'Warn', 'Error', or a number between 0 and 10 with a precision of 1 decimal place"+        )+  types :: [String] <-+    O.many $+      O.option O.str+        ( O.long "log-type"+            <> O.metavar "TYPE"+            <> O.help "Log type, can be specified multiple times"+        )+  nonTypes :: [String] <-+    O.many $+      O.option O.str+        ( O.long "no-log-type"+            <> O.metavar "TYPE"+            <> O.help "Log type to exclude, can be specified multiple times"+        )+  pure $+    LogEffectInitData+      (Logger logger)+      (Just cleanup)+      (foldr (.) id $ [anyLogCat (isLogCatName name) | name <- types] <> [excludeLogCat (isLogCatName name) | name <- nonTypes])+      level

@@ -1,27 +1,45 @@-{-# LANGUAGE AllowAmbiguousTypes, QuasiQuotes, DeriveLift #-}--- | This module provides functionality for handling trace IDs in logging.------  A trace Id is a unique identifier used to trace and correlate log entries across different parts of a system.---  It is particularly useful in systems for tracking requests as they propagate through various services.-module Module.Logging.TraceId where+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuasiQuotes #-} +module Module.Logging.TraceId+  ( -- * Types+    TraceId(..)+    -- * Modules+  , TraceIdGen+  , newTraceId+  , WithTraceId+  , traceId+    -- * Attaching Trace IDs+  , withTraceId+  , withNewTraceId+  , runWithTraceIdIn+    -- * Trace ID Generators+  , withRandomTraceIdGen+  , withTimeTraceIdGen+  , withCountingTraceIdGen+  , withStartTimeCountingTraceIdGen+  , runTraceIdGen+  , runTraceIdGenIn+  , TraceIdGenRead+  , WithTraceIdRead+  ) where+ import Control.Concurrent.STM import Control.Monad.Effect-import Control.Monad.Logger+import Control.Monad.Logger (toLogStr)+import Data.Aeson (FromJSON, ToJSON) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.TypeList import Data.Word-import Data.Aeson (FromJSON, ToJSON) import Module.Logging-import Module.RS.QQ import Module.Logging.TraceId.XorShiftRNG+import Module.RS.QQ -newtype TraceId = TraceId { unTraceId :: Word64 }+newtype TraceId = TraceId {unTraceId :: Word64}   deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)  instance IsLogCat TraceId where-  logTypeDisplay (TraceId tid) = "TID=" <> toLogStr tid-  {-# INLINE logTypeDisplay #-}+  logTypeName (TraceId tid) = "TID=" <> toLogStr tid  [makeRModule__| TraceIdGen@@ -33,86 +51,67 @@   traceId :: !TraceId |] --- | Assign the provided traceId to the logging context withTraceId-  :: forall log m mods es a.+  :: forall doc m mods es a.      ( Monad m-     , Logging m log `In`    mods-     , WithTraceId   `NotIn` mods+     , LogEffect m doc `In` mods+     , WithTraceId `NotIn` mods      , ConsFDataList FData (WithTraceId : mods)      )-  => TraceId -> EffT (WithTraceId : mods) es m a -> EffT mods es m a-withTraceId tid = effAddLogCat @log (LogCat tid) . runWithTraceId (WithTraceIdRead tid)-{-# INLINE withTraceId #-}---- | Specialized for log = LogS-withTraceId'-  :: forall log m mods es a.-     ( Monad m-     , Logging m log `In`    mods-     , WithTraceId   `NotIn` mods-     , ConsFDataList FData (WithTraceId : mods)-     , log ~ LogS-     )-  => TraceId -> EffT (WithTraceId : mods) es m a -> EffT mods es m a-withTraceId' = withTraceId @log-{-# INLINE withTraceId' #-}+  => TraceId+  -> EffT (WithTraceId : mods) es m a+  -> EffT mods es m a+withTraceId tid =+  effAddLogCat @doc (LogCat tid) . runWithTraceId (WithTraceIdRead tid) --- | Assign new traceId using the provided TraceIdGen module withNewTraceId-  :: forall log m mods es a.+  :: forall doc m mods es a.      ( MonadIO m-     , TraceIdGen     `In`    mods-     , Logging m log  `In`    mods-     , WithTraceId    `NotIn` mods-     , ConsFDataList  FData   (WithTraceId : mods)+     , TraceIdGen `In` mods+     , LogEffect m doc `In` mods+     , WithTraceId `NotIn` mods+     , ConsFDataList FData (WithTraceId : mods)      )-  => EffT (WithTraceId : mods) es m a -> EffT mods es m a+  => EffT (WithTraceId : mods) es m a+  -> EffT mods es m a withNewTraceId act = do-  newTidIO <- asksModule newTraceId-  newTrace <- liftIO     newTidIO-  withTraceId @log newTrace act-{-# INLINE withNewTraceId #-}+  mkTraceId <- asksModule newTraceId+  tid <- liftIO mkTraceId+  withTraceId @doc tid act --- | Using a global XorShift random number generator for traceId withRandomTraceIdGen   :: (MonadIO m, ConsFDataList FData (TraceIdGen : mods))-  => EffT (TraceIdGen : mods) es m a -> EffT mods es m a+  => EffT (TraceIdGen : mods) es m a+  -> EffT mods es m a withRandomTraceIdGen act = do   rng <- liftIO newRNG   runTraceIdGen (TraceIdGenRead $ TraceId <$> uniformWord64FromRNG rng) act-{-# INLINE withRandomTraceIdGen #-} --- | Using current time in microsecond precision for traceId withTimeTraceIdGen   :: (MonadIO m, ConsFDataList FData (TraceIdGen : mods))-  => EffT (TraceIdGen : mods) es m a -> EffT mods es m a-withTimeTraceIdGen act = do-  runTraceIdGen (TraceIdGenRead $ TraceId . floor . (*1000_000) <$> getPOSIXTime) act-{-# INLINE withTimeTraceIdGen #-}+  => EffT (TraceIdGen : mods) es m a+  -> EffT mods es m a+withTimeTraceIdGen act =+  runTraceIdGen (TraceIdGenRead $ TraceId . floor . (* 1000_000) <$> getPOSIXTime) act --- | Using a simple counting number for traceId, starting from the provided number withCountingTraceIdGen   :: (MonadIO m, ConsFDataList FData (TraceIdGen : mods))-  => Word64  -- ^ starting count, e.g. you can use microsecond unix time+  => Word64   -> EffT (TraceIdGen : mods) es m a   -> EffT mods es m a withCountingTraceIdGen startCount act = do   counter <- liftIO $ newTVarIO startCount-  let getNewTid = atomically $ do-        tid <- readTVar counter-        let !newTid = tid + 1-        writeTVar counter newTid-        return $ TraceId tid-  runTraceIdGen (TraceIdGenRead getNewTid) act-{-# INLINE withCountingTraceIdGen #-}+  let nextTraceId = atomically $ do+        current <- readTVar counter+        let newValue = current + 1+        writeTVar counter newValue+        pure $ TraceId current+  runTraceIdGen (TraceIdGenRead nextTraceId) act --- | Using current time in microsecond precision as the starting point for a counting traceId generator withStartTimeCountingTraceIdGen   :: (MonadIO m, ConsFDataList FData (TraceIdGen : mods))   => EffT (TraceIdGen : mods) es m a   -> EffT mods es m a withStartTimeCountingTraceIdGen act = do-  startTime <- liftIO $ floor . (*1000_000) <$> getPOSIXTime+  startTime <- liftIO $ floor . (* 1000_000) <$> getPOSIXTime   withCountingTraceIdGen startTime act-{-# INLINE withStartTimeCountingTraceIdGen #-}

@@ -39,7 +39,7 @@   in  z2 `xor` (z2 `shiftR` 31) {-# INLINE mix64 #-} --- ----------------------------------------------------------------------------- +-- ----------------------------------------------------------------------------- -- | Turn one seed into @n@ independent seeds suitable for different threads. -- --   *   Deterministic: same parent → same list.