Log.hs

-- | Log effect with hierarchical namespace support.
--
-- Provides structured logging with composable namespaces for better organization.
--
-- == Basic Usage
--
-- @
-- myComponent :: (Log :> es) => Eff es ()
-- myComponent = do
--     info "Starting component"
--     -- Logs: [INFO] [MyModule.myComponent#42] Starting component
-- @
--
-- == Using Namespaces
--
-- @
-- processData :: (Log :> es) => Eff es ()
-- processData = withNamespace "processor" $ do
--     info "Processing started"
--     -- Logs: [INFO] [processor] [MyModule.processData#10] Processing started
--
--     withNamespace "validation" $ do
--         info "Validating input"
--         -- Logs: [INFO] [processor.validation] [MyModule.processData#13] Validating input
-- @
module Atelier.Effects.Log
    ( -- * Effect
      Log
    , Message (..)
    , Config (..)
    , Severity (..)
    , log
    , info
    , warn
    , debug
    , err
    , withNamespace

      -- * Interpreters
    , runIO
    , runNoOp
    , runToHandle
    , runWriter

      -- * Utils
    , minimumSeverityFromEnv
    )
where

import Data.Aeson (FromJSON (..), ToJSON)
import Data.Default (Default (..))
import Effectful (Effect, IOE)
import Effectful.Dispatch.Dynamic (localSeqUnlift, reinterpret, reinterpretWith)
import Effectful.NonDet (OnEmptyPolicy (..), emptyEff, runNonDet)
import Effectful.Reader.Static (Reader, ask, local, runReader)
import Effectful.TH (makeEffect)
import Effectful.Writer.Static.Shared (Writer, tell)
import System.IO (Handle, hFlush, stdout)

import Data.ByteString.Char8 qualified as B8

import Atelier.Effects.Env (Env)
import Atelier.Types.JSON.QuietSnake (QuietSnake (..))
import Atelier.Types.JSON.ReadShow (ReadShow (..))
import Atelier.Types.JSON.WithDefaults (WithDefaults (..))

import Atelier.Effects.Env qualified as Env


-- | Effect for structured logging with hierarchical namespaces.
data Log :: Effect where
    -- | Emit a fully-formed log 'Message'.
    LogMsg :: Message -> Log m ()
    -- | Run an action with an extra namespace segment appended to the current
    -- one.
    WithNamespace :: Namespace -> m a -> Log m a
    -- | Get the namespace in effect for the current action.
    GetNamespace :: Log m Namespace


-- | A single log record.
data Message = Message
    { namespace :: Namespace
    -- ^ The hierarchical namespace the message was logged under.
    , text :: Text
    -- ^ The human-readable message body.
    , severity :: Severity
    -- ^ The severity level of the message.
    , stack :: CallStack
    -- ^ The call site, captured via 'HasCallStack'.
    }


newtype Namespace = Namespace Text
    deriving stock (Eq, Show)
    deriving newtype (IsString)


instance Semigroup Namespace where
    Namespace "" <> Namespace b = Namespace b
    Namespace a <> Namespace "" = Namespace a
    Namespace a <> Namespace b = Namespace (a <> "." <> b)


-- | Logging configuration.
data Config = Config
    { minimumSeverity :: Severity
    -- ^ Messages below this severity are discarded.
    }
    deriving stock (Eq, Generic, Show)
    deriving (ToJSON) via QuietSnake Config
    deriving (FromJSON) via WithDefaults (QuietSnake Config)


-- | Log severity levels, ordered from least to most severe.
data Severity
    = -- | Verbose diagnostic detail.
      DEBUG
    | -- | Normal operational information.
      INFO
    | -- | Something unexpected, but recoverable.
      WARN
    | -- | A failure that needs attention.
      ERROR
    deriving stock (Bounded, Enum, Eq, Ord, Read, Show)
    deriving (FromJSON) via ReadShow Severity
    deriving (ToJSON) via ReadShow Severity


instance Default Config where
    def =
        Config
            { minimumSeverity = minBound
            }


makeEffect ''Log


-- | Log a message at the given severity, capturing the current namespace and
-- call site.
log :: (HasCallStack, Log :> es) => Severity -> Text -> Eff es ()
log severity text = do
    namespace <- getNamespace
    withFrozenCallStack
        $ logMsg
            Message
                { stack = callStack
                , namespace
                , severity
                , text
                }


-- | Log a message at 'DEBUG' severity.
debug :: (HasCallStack, Log :> es) => Text -> Eff es ()
debug = withFrozenCallStack $ log DEBUG


-- | Log a message at 'INFO' severity.
info :: (HasCallStack, Log :> es) => Text -> Eff es ()
info = withFrozenCallStack $ log INFO


-- | Log a message at 'WARN' severity.
warn :: (HasCallStack, Log :> es) => Text -> Eff es ()
warn = withFrozenCallStack $ log WARN


-- | Log a message at 'ERROR' severity.
err :: (HasCallStack, Log :> es) => Text -> Eff es ()
err = withFrozenCallStack $ log ERROR


-- | Consumes `Log` effects, and discards the logged messages
runNoOp :: Eff (Log : es) a -> Eff es a
runNoOp = reinterpret (runReader (Namespace "")) $ \env -> \case
    LogMsg _ -> pure ()
    WithNamespace ns act -> localSeqUnlift env $ \unlift ->
        local (<> ns) $ unlift act
    GetNamespace -> ask


-- | Interpret 'Log' by writing formatted messages to stdout.
--
-- The minimum severity defaults to 'Config'\'s @minimumSeverity@, but can be
-- overridden at runtime by the @DEBUG@, @LOGGING@ or @LOG@ environment
-- variables (checked in that order).
runIO :: (Env :> es, IOE :> es, Reader Config :> es) => Eff (Log : es) a -> Eff es a
runIO action = do
    config <- ask
    severity <- fromMaybe config.minimumSeverity <$> minimumSeverityFromEnv

    reinterpretWith (runReader (Namespace "")) action \lenv -> \case
        LogMsg msg ->
            liftIO $ when (msg.severity >= severity) do
                -- NOTE: We use hPutStr here with an appended newline because
                -- hPutStrLn is not atomic for ByteStrings longer than 1024 bytes.
                -- Data.Text.IO.hPutStrLn is not atomic for even short Texts.
                B8.hPutStr stdout
                    . encodeUtf8
                    . (<> "\n")
                    . formatMessage
                    $ msg
                hFlush stdout
        WithNamespace ns act -> localSeqUnlift lenv $ \unlift ->
            local (<> ns) $ unlift act
        GetNamespace -> ask


-- | Like 'runLog' but writes to the given 'Handle' instead of stdout.
-- Useful for daemons that want to write logs to a file.
runToHandle :: (IOE :> es) => Handle -> Severity -> Eff (Log : es) a -> Eff es a
runToHandle handle minSeverity action =
    reinterpretWith (runReader (Namespace "")) action \env -> \case
        LogMsg msg ->
            liftIO $ when (msg.severity >= minSeverity) do
                B8.hPutStr handle . encodeUtf8 . (<> "\n") . formatMessage $ msg
                hFlush handle
        WithNamespace ns act -> localSeqUnlift env $ \unlift ->
            local (<> ns) $ unlift act
        GetNamespace -> ask


-- | Interpret 'Log' by collecting messages into a 'Writer', for tests.
runWriter :: (Writer [Message] :> es) => Eff (Log : es) a -> Eff es a
runWriter = reinterpret (runReader (Namespace "")) $ \env -> \case
    LogMsg msg -> tell [msg]
    WithNamespace ns act -> localSeqUnlift env $ \unlift ->
        local (<> ns) $ unlift act
    GetNamespace -> ask


formatMessage :: Message -> Text
formatMessage msg =
    mconcat
        [ square $ show msg.severity
        , " "
        , showNamespace msg.namespace
        , msg.text
        ]
  where
    showNamespace (Namespace "") = ""
    showNamespace (Namespace ns) = square ns <> " "


minimumSeverityFromEnv :: (Env :> es) => Eff es (Maybe Severity)
minimumSeverityFromEnv = do
    fmap rightToMaybe
        $ runNonDet OnEmptyKeep
        $ asum
            [ Env.lookup "LOG" >>= readAlt
            , Env.lookup "LOGGING" >>= readAlt
            , Env.lookup "DEBUG" >>= \case
                Nothing -> emptyEff
                Just x
                    | x == "0" -> emptyEff
                    | otherwise -> pure DEBUG
            ]
  where
    readAlt Nothing = emptyEff
    readAlt (Just x) = case readMaybe x of
        Nothing -> emptyEff
        Just x' -> pure x'


square :: Text -> Text
square s = "[" <> s <> "]"