packages feed

monad-effect-logging (empty) → 0.1.0.0

raw patch · 10 files changed

+1409/−0 lines, 10 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, clock, fast-logger, lens, monad-effect, monad-logger, primitive, stm, template-haskell, text, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for rst-logger++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Eiko+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,227 @@+# 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:++* (Optional) Separation of log generation and rendering++* Pure logging++* Extensible log categories++* Compatible with `monad-logger`++* `TraceId` support++## Type Definition++```haskell+import qualified Control.Monad.Logger as ML++data Logging m a++instance Module (Logging m (a :: Type)) where+  newtype ModuleRead  (Logging m a) = LoggingRead+    { logging :: Logger m a+    }+  data    ModuleState (Logging m a) = LoggingState++data Log a = Log+  { _logType    :: [LogCat]+  , _logContent :: a+  } deriving (Functor)++data LogMsg a = LogMsg+  { _logLoc    :: Maybe ML.Loc+  , _logSource :: Maybe ML.LogSource+  , _logMsg    :: a+  }+```++A `Logger m a` is just a function that takes a `Log a` and produces an effect in `m ()`.++```haskell+type Logger :: (Type -> Type) -> Type -> Type+newtype Logger m a = Logger+  { _runLogger :: Log a -> m ()+  }+```++## Features++I developed it by using it and changing it to meet my needs. It solves the following problems:++### Separation Of Logs and Rendering++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.++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).++See `Module.Logging.LogB` for relevant functions and types. Here is an example:++```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+```++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++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).++```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+```++### Extensible Log Categories++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.++```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++-- | 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 #-}+```++Here is an example of defining your own log category `ProxyLog`:++```haskell+import Module.Logging as L+import Language.Haskell.TH.Syntax (Lift)++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"+```++The `Lift` class is only necessary if you want to use them inside `logTH` template haskell utilities, otherwise you can remove it.++To use them, using functions in `Module.Logging.LogS` or `Module.Logging.LogB`, under corresponding logging context:++```haskell+import Module.Logging+import Module.Logging.LogS++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"+```++### Compatible With `monad-logger`++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`.++```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+```++### `TraceId` Support++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.++We also included some optional trace id generation utilities.++See `Module.Logging.TraceId` for relevant functions and types.
+ monad-effect-logging.cabal view
@@ -0,0 +1,96 @@+cabal-version:      2.4+-- Initial package description 'monad-effect-logger' generated by+-- 'cabal init'. For further documentation, see:+--   http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name:               monad-effect-logging++-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version:            0.1.0.0++-- A short (one-line) description of the package.+synopsis: A flexible logging system utilizing the `monad-effect` effect system.++-- A longer description of the package.+description: A flexible logging system utilizing the `monad-effect` effect system, it gives you very fine control over the logging behavior, including custom categories, separation of log generation and rendering, pure logging effect, compatibility with monad-logger, trace-id support, etc.++-- The license under which the package is released.+license:            BSD-3-Clause++-- The file containing the license text.+license-file:       LICENSE++-- The package author(s).+author:             Eiko++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer:         eikochanowo@outlook.com++-- A copyright notice.+-- copyright:+category:           Control+build-type:         Simple++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md+               , README.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++source-repository head+  type: git+  location: https://github.com/Eiko-Tokura/monad-effect-logging.git++common warnings+    ghc-options: -Wall++library+    -- Import common warning flags.+    import:           warnings++    -- 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++    -- Modules included in this library but not exported.+    other-modules: Module.Logging.TraceId.XorShiftRNG+    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:++    -- Other library packages from which modules are imported.+    build-depends: base >= 4 && < 5+                 , aeson < 2.3+                 , bytestring < 0.13+                 , fast-logger >= 3 && < 3.3+                 , lens < 5.4+                 , monad-effect >= 0.2.1 && < 0.3+                 , monad-logger >= 0.3 && < 0.4+                 , stm >= 2.5 && < 2.6+                 , text < 2.2+                 , time < 1.15+                 , template-haskell >= 2.20 && < 2.24+                 , primitive < 0.10+                 , clock < 0.9++    -- Directories containing source files.+    hs-source-dirs:   src++    -- Base language which the package is written in.+    default-language: GHC2021++    default-extensions: OverloadedStrings+                      , DerivingStrategies+                      , DerivingVia+                      , DataKinds+                      , GADTs+                      , LambdaCase+                      , TypeFamilies+                      , TypeApplications
+ src/Module/Logging.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE TemplateHaskell, UndecidableInstances, AllowAmbiguousTypes, DeriveLift, OverloadedRecordDot #-}+{-# 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+    LogSeverity+  , IsLogCat(..)+  , LogCat(..)+  , Log(..), logType, logContent+  , LogMsg(..), logLoc, logSource, logMsg+  , Logger(..), runLogger+  , Logging+  , LoggingModule+  -- * Default log categories+  , Debug(..)+  , Info(..)+  , Warn(..)+  , Error(..)+  , Other(..)+  -- * Default log implementation+  , toLogStrS+  , logLog+  , LogS+  , LogData+  -- * Combinators+  , localLogger+  , localLog+  , addLogCat+  , effAddLogCat+  , effAddLogCat'+  , filterLogCats+  , anyLogCat+  , excludeLogCat+  , severityThat+  , noSeverity+  , isLogCat+  , isLogSubType+  , isLogCatName+  , someSeverity+  , someLogCatName+  -- * Running and initializing+  , runLogging+  , withLiftLogger+  -- * Other optional utilities+  , defaultStringToLogSeverity+  , defaultLoggingFromEnv+  , defaultLoggingFromArgs+  , monadLoggerAdapter+  , mlLogLevelToLogCat++  -- * Re-export+  , 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 Data.Fixed+import Data.Functor.Contravariant+import Data.Kind+import Data.Maybe+import Data.Text (Text)+import Data.Typeable+import qualified Control.Monad.Logger as ML++import System.Environment+import Text.Read (readMaybe)++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+  severity _ = Nothing+  {-# INLINE severity #-}+  -- | This is used for display only+  logTypeDisplay :: sub -> ML.LogStr+  {-# MINIMAL logTypeDisplay #-}++instance IsLogCat Text where+  logTypeDisplay = ML.toLogStr+  {-# INLINE logTypeDisplay #-}++-- | 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++someSeverity :: LogCat -> Maybe LogSeverity+someSeverity (LogCat @a subType) = severity @a subType+{-# INLINE someSeverity #-}++someLogCatName :: LogCat -> ML.LogStr+someLogCatName (LogCat @a subType) = logTypeDisplay @a subType+{-# INLINE someLogCatName #-}++data Log a = Log+  { _logType    :: [LogCat]+  , _logContent :: a+  } deriving (Functor)++type LogS = LogMsg ML.LogStr++type LogData = LogS+{-# DEPRECATED LogData "Use LogS instead" #-}++data LogMsg a = LogMsg+  { _logLoc    :: Maybe ML.Loc+  , _logSource :: Maybe ML.LogSource+  , _logMsg    :: a+  }++makeLenses ''Log+makeLenses ''LogMsg+makeLenses ''Loc++instance Functor LogMsg where+  fmap f logMsg' = logMsg' { _logMsg = f (_logMsg logMsg') }+  {-# INLINE fmap #-}++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+    }+  {-# INLINE (<>) #-}++instance Monoid a => Monoid (LogMsg a) where+  mempty = LogMsg Nothing Nothing mempty+  {-# INLINE mempty #-}++-- | 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 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 Semigroup a => Semigroup (Log a) where+  Log t1 c1 <> Log t2 c2 = Log (t1 <> t2) (c1 <> c2)+  {-# INLINE (<>) #-}++instance Monoid a => Monoid (Log a) where+  mempty = Log [] mempty+  {-# INLINE mempty #-}++instance Applicative Log where+  pure = Log []+  {-# INLINE pure #-}+  Log t1 f <*> Log t2 a = Log (t1 <> t2) (f a)+  {-# INLINE (<*>) #-}++instance Monad Log where+  (Log t a) >>= f =+    let Log t' a' = f a+    in Log (t <> t') a'+  {-# INLINE (>>=) #-}++type Logger :: (Type -> Type) -> Type -> Type+newtype Logger m a = Logger+  { _runLogger :: Log a -> m ()+  }++liftLogger :: (m () -> n ()) -> Logger m b -> Logger n b+liftLogger f (Logger g) = Logger (f . g)+{-# INLINE liftLogger #-}++makeLenses ''Logger++instance Applicative m => Semigroup (Logger m a) where+  Logger f <> Logger g = Logger $ \log' -> f log' *> g log'+  {-# INLINE (<>) #-}++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+--     ...+-- @++-- | 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 #-}++-- | 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 #-}++-- | Add a log category to the log+-- @+-- localLogger (addLogCat $ LogCat ConnectionPool) $ do+--   ...+-- @+addLogCat :: LogCat -> Logger m a -> Logger m a+addLogCat t = over runLogger (. over logType (t:))+{-# INLINE addLogCat #-}++-- | 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 #-}++-- | 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' #-}++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 #-}++anyLogCat :: Applicative m => Predicate LogCat -> Logger m a -> Logger m a+anyLogCat p = filterLogCats (Predicate $ any p.getPredicate)+{-# INLINE anyLogCat #-}++excludeLogCat :: Applicative m => Predicate LogCat -> Logger m a -> Logger m a+excludeLogCat p = filterLogCats (Predicate $ not . any p.getPredicate)+{-# INLINE excludeLogCat #-}++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 #-}++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 #-}++isLogCatName :: ML.ToLogStr n => n -> Predicate LogCat+isLogCatName name = Predicate $ \logCat -> someLogCatName logCat == ML.toLogStr name+{-# INLINE isLogCatName #-}++-- | 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 LoggingModule = Logging IO LogS -- standard logging module++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+withLiftLogger lifter act = do+  LoggingRead logger <- askModule @(Logging m a)+  let logger' = liftLogger lifter logger+  embedMods $ runEffTOuter_ (LoggingRead logger') LoggingState act++instance Module (Logging m (a :: Type)) where+  newtype ModuleRead  (Logging m a) = LoggingRead+    { logging :: Logger m a+    }+  data    ModuleState (Logging m a) = LoggingState++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 #-}++instance SystemModule (Logging m a) where+  data    ModuleInitData (Logging m a) = LoggingInitData+    { loggerInitLogger   :: Logger IO a+    , loggerInitSeverity :: Maybe LogSeverity+    , loggerInitCleanup  :: Maybe (IO ())+    }+  data    ModuleEvent    (Logging m a) = LoggingEvent++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 EventLoop c (Logging 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+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 #-}++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+      }+  }+{-# 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 (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 #-}++-- | 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 #-}
+ src/Module/Logging/LogB.hs view
@@ -0,0 +1,114 @@+-- | 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) |]
+ src/Module/Logging/LogS.hs view
@@ -0,0 +1,78 @@+{-# 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) |]
+ src/Module/Logging/Logger.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE RecordWildCards, DuplicateRecordFields #-}+-- | Some simple combinators to build your logger+module Module.Logging.Logger+  ( module Module.Logging.Logger+  -- * Re-exporting fast-logger+  , module System.Log.FastLogger+  ) where++import Control.Monad+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Effect+import Data.Time.Clock+import Module.Logging+import System.Log.FastLogger+import System.Log.FastLogger.Internal (LogStr (..))+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)++-- | Logger with a cleanup function+data LoggerWithCleanup m log = LoggerWithCleanup+  { baseLogFunc :: log -> 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 #-}++-- | 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' #-}++liftBaseLogger :: (m () -> n ()) -> LoggerWithCleanup m log -> LoggerWithCleanup n log+liftBaseLogger nat (LoggerWithCleanup f c) = LoggerWithCleanup (nat . f) (nat c)+{-# INLINE liftBaseLogger #-}++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+  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++-- | 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 #-}++-- | 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++-- | 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)++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++-- | 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 #-}++-- | simply apply the provided function to the log string+baseToLogger :: (LogStr -> m ()) -> Logger m LogStr+baseToLogger baseIO = Logger $ \(Log _ str) -> baseIO str+{-# INLINE baseToLogger #-}++-- | 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 #-}++-- | 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 #-}++-- | 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 #-}++-- | Bracket pattern, runs the action with the provided logger and cleans up afterwards+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 #-}++-- $ 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+  -> 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 #-}++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 a+withBaseLoggerIO createBaseLogger makeLogger action = bracket+  (liftIO createBaseLogger)+  (\LoggerWithCleanup {cleanUpFunc} -> liftIO cleanUpFunc)+  (\LoggerWithCleanup {baseLogFunc} -> action (makeLogger baseLogFunc))+{-# INLINE withBaseLoggerIO #-}
+ src/Module/Logging/TraceId.hs view
@@ -0,0 +1,118 @@+{-# 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++import Control.Concurrent.STM+import Control.Monad.Effect+import Control.Monad.Logger+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++newtype TraceId = TraceId { unTraceId :: Word64 }+  deriving newtype (Eq, Ord, Show, FromJSON, ToJSON)++instance IsLogCat TraceId where+  logTypeDisplay (TraceId tid) = "TID=" <> toLogStr tid+  {-# INLINE logTypeDisplay #-}++[makeRModule__|+TraceIdGen+  newTraceId :: !(IO TraceId)+|]++[makeRModule__|+WithTraceId+  traceId :: !TraceId+|]++-- | Assign the provided traceId to the logging context+withTraceId+  :: forall log m mods es a.+     ( Monad m+     , Logging m log `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' #-}++-- | Assign new traceId using the provided TraceIdGen module+withNewTraceId+  :: forall log m mods es a.+     ( MonadIO m+     , TraceIdGen     `In`    mods+     , Logging m log  `In`    mods+     , WithTraceId    `NotIn` mods+     , ConsFDataList  FData   (WithTraceId : mods)+     )+  => 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 #-}++-- | 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+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 #-}++-- | 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+  -> 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 #-}++-- | 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+  withCountingTraceIdGen startTime act+{-# INLINE withStartTimeCountingTraceIdGen #-}
+ src/Module/Logging/TraceId/XorShiftRNG.hs view
@@ -0,0 +1,102 @@+-- | This module provides an implementation of a XorShift random number generator (RNG)+-- and a monad transformer for using it in computations.+--+-- It is lightweight and fast.+module Module.Logging.TraceId.XorShiftRNG+  ( -- * RNG+    RNG, newRNG, uniformDoubleFromRNG, uniformWord64FromRNG+    -- * RNGT+  , newWord64IO+    -- * MonadUniformValue+  , Word64, nextWord64, word64ToDouble, splitSeeds, mix64+  ) where++import Foreign+import System.Clock+import Control.Monad.IO.Class++import GHC.Exts (RealWorld)+import qualified Data.Primitive.PrimArray as P+++-- | The RNG state, which is a foreign pointer to a 64-bit unsigned integer.+newtype RNG = RNG (P.MutablePrimArray RealWorld Word64)+--(ForeignPtr Word64)++-- | Working with seeds+nextWord64 :: Word64 -> Word64+nextWord64 !x0 =+  let !x1 = x0 `xor` (x0 `shiftL` 13)+      !x2 = x1 `xor` (x1 `shiftR` 7)+  in  (x2 `xor`) $! (x2 `shiftL` 17)+{-# INLINE nextWord64 #-}++-- SplitMix64 "avalanche" ------------------------------------------------------+mix64 :: Word64 -> Word64+mix64 !z0 =+  let !z1 = (z0 `xor` (z0 `shiftR` 30)) * 0xbf58476d1ce4e5b9+      !z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94d049bb133111eb+  in  z2 `xor` (z2 `shiftR` 31)+{-# INLINE mix64 #-}++-- ----------------------------------------------------------------------------- +-- | Turn one seed into @n@ independent seeds suitable for different threads.+--+--   *   Deterministic: same parent → same list.+--   *   Fast:   O(n), two multiplies + a few shifts per child.+--   *   Guarantees no child gets 0 (bad for XorShift).+--+splitSeeds :: [a] -> Word64 -> [(a, Word64)]+splitSeeds n parent =+  [ (a, forceNonZero . mix64 $ parent + fromIntegral i * 0x9e3779b97f4a7c15)+  | (i, a) <- zip [0::Int ..] n+  ]+  where+    -- XorShift fails when state == 0 or 0x8000000000000000.+    forceNonZero 0 = 0x6a09e667f3bcc908  -- arbitrary non-zero constant+    forceNonZero w = w+{-# INLINE splitSeeds #-}++newWord64IO :: MonadIO m => m Word64+newWord64IO = do+  TimeSpec s n <- liftIO $ getTime Monotonic+  pure $! fromIntegral s `xor` fromIntegral n+{-# INLINE newWord64IO #-}++word64ToDouble :: Word64 -> Double+word64ToDouble !x =+  let !d = fromIntegral (x `shiftR` 11) * 1.1102230246251565e-16+      -- 1/2^53 = 1.110…e-16+  in d+{-# INLINE word64ToDouble #-}++-- | Create a new RNG instance seeded with the current time.+newRNG :: IO RNG+newRNG = do+  marr <- P.newPrimArray 1 -- Create a mutable array of size 1+  TimeSpec s n <- getTime Monotonic -- Get current time in seconds and nanoseconds+  let !seed = fromIntegral s `xor` fromIntegral n -- Combine seconds and nanoseconds+  P.writePrimArray marr 0 seed -- Write the seed into the array with 0 index+  pure $ RNG marr+{-# INLINE newRNG #-}++-- | Generate a uniform random double in the range [0, 1) using the XorShift algorithm.+-- updates the RNG state.+uniformDoubleFromRNG :: RNG -> IO Double+uniformDoubleFromRNG rng = do+  x3 <- uniformWord64FromRNG rng+  -- top 53 bits → [0,1)+  pure $! fromIntegral (x3 `shiftR` 11) * 1.1102230246251565e-16+{-# INLINE uniformDoubleFromRNG #-}++-- | Generate a uniform Word64 using the XorShift algorithm.+-- updates the RNG state.+uniformWord64FromRNG :: RNG -> IO Word64+uniformWord64FromRNG (RNG marr) = do+  !x0 <- P.readPrimArray marr 0 -- Read the current state+  let !x1 = x0 `xor` (x0 `shiftL` 13)+      !x2 = x1 `xor` (x1 `shiftR` 7)+      !x3 = x2 `xor` (x2 `shiftL` 17)+  P.writePrimArray marr 0 x3 -- Update the state+  pure $! x3+{-# INLINE uniformWord64FromRNG #-}