{- |
Module      : GHC.Eventlog.Live.Internal.Logger
Description : /Internal module/. Logging functions.
Stability   : experimental
Portability : portable

This module is __internal__. The [PVP](https://pvp.haskell.org) __does not apply__.
-}
module GHC.Eventlog.Live.Internal.Logger (
  LogSource,
  logMessage,
  logError,
  logWarning,
  logInfo,
  logDebug,
) where

import Control.Exception (bracket_)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import GHC.Eventlog.Live.Verbosity (Verbosity, showVerbosity, verbosityDebug, verbosityError, verbosityInfo, verbosityWarning)
import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), hNowSupportsANSI, hSetSGR)
import System.IO qualified as IO

{- |
Internal helper. Denotes the source of a log message.
-}
type LogSource = Text

{- |
Internal helper. Log messages to given handle.
Only prints a message if its verbosity level is above the verbosity threshold.
-}
logMessage :: (MonadIO m) => IO.Handle -> Verbosity -> Verbosity -> LogSource -> Text -> m ()
logMessage :: forall (m :: * -> *).
MonadIO m =>
Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
logMessage Handle
handle Verbosity
verbosityLevel Verbosity
verbosityThreshold Text
logSource Text
msg
  | Verbosity
verbosityLevel Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbosityThreshold = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> Handle -> (Handle -> IO ()) -> IO ()
forall a. Verbosity -> Handle -> (Handle -> IO a) -> IO a
withVerbosityColor Verbosity
verbosityLevel Handle
handle
        ((Handle -> IO ()) -> IO ())
-> (Text -> Handle -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> Text -> IO ()) -> Text -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> Text -> IO ()
TIO.hPutStrLn
        (Text -> Handle -> IO ())
-> (Text -> Text) -> Text -> Handle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> Verbosity -> Text -> Text -> Text
formatMessage Verbosity
verbosityLevel Verbosity
verbosityThreshold Text
logSource
        (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
msg
      Handle -> IO ()
IO.hFlush Handle
handle
  | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{- |
Internal helper. Format the message appropriately for the given verbosity level and threshold.
-}
formatMessage :: Verbosity -> Verbosity -> LogSource -> Text -> Text
formatMessage :: Verbosity -> Verbosity -> Text -> Text -> Text
formatMessage Verbosity
verbosityLevel Verbosity
verbosityThreshold Text
logSource Text
msg
  | Verbosity
verbosityLevel Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
verbosityInfo Bool -> Bool -> Bool
&& Verbosity
verbosityThreshold Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
verbosityDebug = Text
msg
  | Bool
otherwise = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Verbosity -> Text
showVerbosity Verbosity
verbosityLevel, String -> Text
T.pack String
"[", Text
logSource, String -> Text
T.pack String
"]: ", Text
msg]

{- |
Internal helper. Use a handle with the color set appropriately for the given verbosity level.
-}
withVerbosityColor :: Verbosity -> IO.Handle -> (IO.Handle -> IO a) -> IO a
withVerbosityColor :: forall a. Verbosity -> Handle -> (Handle -> IO a) -> IO a
withVerbosityColor Verbosity
verbosity Handle
handle Handle -> IO a
action = do
  Bool
supportsANSI <- Handle -> IO Bool
hNowSupportsANSI Handle
handle
  if Bool -> Bool
not Bool
supportsANSI
    then
      Handle -> IO a
action Handle
handle
    else case Verbosity -> Maybe Color
verbosityColor Verbosity
verbosity of
      Maybe Color
Nothing ->
        Handle -> IO a
action Handle
handle
      Just Color
color -> do
        let setVerbosityColor :: IO ()
setVerbosityColor = Handle -> [SGR] -> IO ()
hSetSGR Handle
handle [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
color]
        let setDefaultColor :: IO ()
setDefaultColor = Handle -> [SGR] -> IO ()
hSetSGR Handle
handle [ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
Foreground]
        IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
setVerbosityColor IO ()
setDefaultColor (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Handle -> IO a
action Handle
handle

{- |
Internal helper. Determine the ANSI color associated with a particular verbosity level.
-}
verbosityColor :: Verbosity -> Maybe Color
verbosityColor :: Verbosity -> Maybe Color
verbosityColor Verbosity
verbosity
  | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
verbosityError = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Red
  | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
verbosityWarning = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Yellow
  | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
verbosityDebug = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Blue
  | Bool
otherwise = Maybe Color
forall a. Maybe a
Nothing

{- |
Internal helper. Log errors to `IO.stderr`.
-}
logError :: (MonadIO m) => Verbosity -> LogSource -> Text -> m ()
logError :: forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logError = Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
logMessage Handle
IO.stderr Verbosity
verbosityError

{- |
Internal helper. Log warnings to `IO.stderr`.
-}
logWarning :: (MonadIO m) => Verbosity -> LogSource -> Text -> m ()
logWarning :: forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logWarning = Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
logMessage Handle
IO.stderr Verbosity
verbosityWarning

{- |
Internal helper. Log info messages to `IO.stderr`.
-}
logInfo :: (MonadIO m) => Verbosity -> LogSource -> Text -> m ()
logInfo :: forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logInfo = Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
logMessage Handle
IO.stdout Verbosity
verbosityInfo

{- |
Internal helper. Log debug messages to `IO.stderr`.
-}
logDebug :: (MonadIO m) => Verbosity -> LogSource -> Text -> m ()
logDebug :: forall (m :: * -> *).
MonadIO m =>
Verbosity -> Text -> Text -> m ()
logDebug = Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> Verbosity -> Verbosity -> Text -> Text -> m ()
logMessage Handle
IO.stderr Verbosity
verbosityDebug