content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE RankNTypes #-}
  
  -- | Simple Logger API using co-log style loggers
  module GHC.Debugger.Logger (
    -- * The core Logger type
    Recorder,
    logWith,
    -- * Log messages
    Pretty(..),
    -- * For simpler usage
    Colog.LogAction (..),
    toCologAction,
    fromCologAction,
    -- * Severity
    Severity (..),
    WithSeverity (..),
    cmap,
    cmapIO,
    cmapWithSev,
    -- * Verbosity
    Verbosity(..),
    applyVerbosity,
  
    -- * Pretty printing of logs
    renderPrettyWithSeverity,
    renderWithSeverity,
    renderPretty,
    renderSeverity,
    renderWithTimestamp,
  
    -- Re-exports
    module Data.Functor.Contravariant,
  ) where
  
  import GHC.Stack
  
  import Control.Monad.IO.Class
  import Control.Monad ((>=>))
  
  import Colog.Core (Severity(..), WithSeverity(..), filterBySeverity)
  import qualified Colog.Core as Colog
  import Data.Functor.Contravariant (Contravariant (contramap))
  import Data.Text (Text)
  import qualified Data.Text as T
  import Prettyprinter
  import Prettyprinter.Render.Text (renderStrict)
  import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
  
  newtype Recorder msg = Recorder
    { logger_ :: forall m. (MonadIO m) => msg -> m () }
  
  instance Contravariant Recorder where
    contramap f Recorder{ logger_ } =
      Recorder
        { logger_ = logger_ . f }
  
  instance Semigroup (Recorder msg) where
    (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =
      Recorder
        { logger_ = \msg -> logger_1 msg >> logger_2 msg }
  
  instance Monoid (Recorder msg) where
    mempty =
      Recorder
        { logger_ = \_ -> pure () }
  
  -- | Logging verbosity, where all Severities matching or exceeding the threshold are printed
  newtype Verbosity = Verbosity { threshold :: Severity }
  
  -- | Make this logger never report messages whose severity is below the given verbosity severity.
  applyVerbosity :: Verbosity -> Recorder (WithSeverity a) -> Recorder (WithSeverity a)
  applyVerbosity Verbosity{threshold} rc
    = fromCologAction $ filterBySeverity threshold getSeverity (toCologAction rc)
  
  logWith :: (HasCallStack, MonadIO m) => Recorder (WithSeverity msg) -> Severity -> msg -> m ()
  logWith Recorder{logger_} sev msg = logger_ $ WithSeverity msg sev
  
  cmap :: (a -> b) -> Recorder b -> Recorder a
  cmap = contramap
  
  cmapWithSev :: (a -> b) -> Recorder (WithSeverity b) -> Recorder (WithSeverity a)
  cmapWithSev f = contramap (fmap f)
  
  cmapIO :: (a -> IO b) -> Recorder b -> Recorder a
  cmapIO f Recorder{ logger_ } =
    Recorder
      { logger_ = (liftIO . f) >=> logger_ }
  
  renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text
  renderPrettyWithSeverity =
    renderWithSeverity renderPretty
  
  renderWithSeverity :: (a -> Text) -> WithSeverity a -> Text
  renderWithSeverity f msgWithSev =
    renderSeverity (getSeverity msgWithSev) <> " " <> f (getMsg msgWithSev)
  
  renderPretty :: Pretty a => a -> Text
  renderPretty a =
    let
      docToText = renderStrict . layoutPretty defaultLayoutOptions
    in
      docToText (pretty a)
  
  renderWithTimestamp :: Text -> IO Text
  renderWithTimestamp msg = do
    t <- getCurrentTime
    let timeStamp = utcTimeToText t
    pure $ "[" <> timeStamp <> "]" <> msg
    where
      utcTimeToText utcTime = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime
  
  renderSeverity :: Severity -> Text
  renderSeverity = \ case
    Debug -> "[DEBUG]"
    Info -> "[INFO]"
    Warning -> "[WARNING]"
    Error -> "[ERROR]"
  
  toCologAction :: (MonadIO m, HasCallStack) => Recorder msg -> Colog.LogAction m msg
  toCologAction (Recorder logger_) = Colog.LogAction $ \msg -> do
      logger_ msg
  
  fromCologAction :: (HasCallStack) => Colog.LogAction IO msg -> Recorder msg
  fromCologAction (Colog.LogAction logger_) = Recorder $ \msg -> do
      liftIO $ logger_ msg
  