{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : GHC.Eventlog.Live..Logger
Description : Logging functions.
Stability   : experimental
Portability : portable
-}
module GHC.Eventlog.Live.Logger (
  logError,
  logWarning,
  logInfo,
  logDebug,
) where

import Control.Exception (bracket_)
import Control.Monad.IO.Class (MonadIO (..))
import Data.List qualified as L
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 GHC.Stack (CallStack, HasCallStack, SrcLoc (..), callStack, getCallStack)
import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleLayer (..), SGR (..), hNowSupportsANSI, hSetSGR)
import System.IO qualified as IO

{- |
Log messages to given handle.
Only prints a message if its verbosity level is above the verbosity threshold.
-}
logMessage :: (MonadIO m) => IO.Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
logMessage :: forall (m :: * -> *).
MonadIO m =>
Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
logMessage Handle
handle CallStack
theCallStack Verbosity
verbosityLevel Verbosity
verbosityThreshold 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 -> CallStack -> Text -> Text
formatMessage Verbosity
verbosityLevel Verbosity
verbosityThreshold CallStack
theCallStack
        (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 `CallStack`.
-}
formatCallStack :: CallStack -> Text
formatCallStack :: CallStack -> Text
formatCallStack CallStack
theCallStack =
  Text
-> (((String, SrcLoc), [(String, SrcLoc)]) -> Text)
-> Maybe ((String, SrcLoc), [(String, SrcLoc)])
-> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
T.empty (SrcLoc -> Text
formatSrcLoc (SrcLoc -> Text)
-> (((String, SrcLoc), [(String, SrcLoc)]) -> SrcLoc)
-> ((String, SrcLoc), [(String, SrcLoc)])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> (((String, SrcLoc), [(String, SrcLoc)]) -> (String, SrcLoc))
-> ((String, SrcLoc), [(String, SrcLoc)])
-> SrcLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, SrcLoc), [(String, SrcLoc)]) -> (String, SrcLoc)
forall a b. (a, b) -> a
fst) ([(String, SrcLoc)] -> Maybe ((String, SrcLoc), [(String, SrcLoc)])
forall a. [a] -> Maybe (a, [a])
L.uncons (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
theCallStack))
 where
  formatSrcLoc :: SrcLoc -> Text
  formatSrcLoc :: SrcLoc -> Text
formatSrcLoc SrcLoc
srcLoc =
    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [String -> Text
T.pack SrcLoc
srcLoc.srcLocFile, Text
":", String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show SrcLoc
srcLoc.srcLocStartLine), Text
":", String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show SrcLoc
srcLoc.srcLocStartCol)]

{- |
Internal helper.
Format the message appropriately for the given verbosity level and threshold.
-}
formatMessage :: Verbosity -> Verbosity -> CallStack -> Text -> Text
formatMessage :: Verbosity -> Verbosity -> CallStack -> Text -> Text
formatMessage Verbosity
verbosityLevel Verbosity
verbosityThreshold CallStack
theCallStack 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, Text
" (", CallStack -> Text
formatCallStack CallStack
theCallStack, Text
"): ", 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

{- |
Log errors to `IO.stderr`.
-}
logError :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m ()
logError :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logError = Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
logMessage Handle
IO.stderr CallStack
HasCallStack => CallStack
callStack Verbosity
verbosityError

{- |
Log warnings to `IO.stderr`.
-}
logWarning :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m ()
logWarning :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logWarning = Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
logMessage Handle
IO.stderr CallStack
HasCallStack => CallStack
callStack Verbosity
verbosityWarning

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

{- |
Log debug messages to `IO.stderr`.
-}
logDebug :: (HasCallStack, MonadIO m) => Verbosity -> Text -> m ()
logDebug :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Verbosity -> Text -> m ()
logDebug = Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
forall (m :: * -> *).
MonadIO m =>
Handle -> CallStack -> Verbosity -> Verbosity -> Text -> m ()
logMessage Handle
IO.stderr CallStack
HasCallStack => CallStack
callStack Verbosity
verbosityDebug