{-# 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,

  -- * 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(..))
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
  { forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall m. (MonadIO m) => msg -> m () }

instance Contravariant Recorder where
  contramap :: forall a' a. (a' -> a) -> Recorder a -> Recorder a'
contramap a' -> a
f Recorder{ forall (m :: * -> *). MonadIO m => a -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ } =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => a' -> m ()
logger_ = a -> m ()
forall (m :: * -> *). MonadIO m => a -> m ()
logger_ (a -> m ()) -> (a' -> a) -> a' -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f }

instance Semigroup (Recorder msg) where
  <> :: Recorder msg -> Recorder msg -> Recorder msg
(<>) Recorder{ logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = forall (m :: * -> *). MonadIO m => msg -> m ()
logger_1 } Recorder{ logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = forall (m :: * -> *). MonadIO m => msg -> m ()
logger_2 } =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = \msg
msg -> msg -> m ()
forall (m :: * -> *). MonadIO m => msg -> m ()
logger_1 msg
msg m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> msg -> m ()
forall (m :: * -> *). MonadIO m => msg -> m ()
logger_2 msg
msg }

instance Monoid (Recorder msg) where
  mempty :: Recorder msg
mempty =
    Recorder
      { logger_ :: forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ = \msg
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () }

logWith :: (HasCallStack, MonadIO m) => Recorder (WithSeverity msg) -> Severity -> msg -> m ()
logWith :: forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithSeverity msg) -> Severity -> msg -> m ()
logWith (Recorder forall (m :: * -> *). MonadIO m => WithSeverity msg -> m ()
logger_) Severity
sev msg
msg = WithSeverity msg -> m ()
forall (m :: * -> *). MonadIO m => WithSeverity msg -> m ()
logger_ (WithSeverity msg -> m ()) -> WithSeverity msg -> m ()
forall a b. (a -> b) -> a -> b
$ msg -> Severity -> WithSeverity msg
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity msg
msg Severity
sev

cmap :: (a -> b) -> Recorder b -> Recorder a
cmap :: forall a' a. (a' -> a) -> Recorder a -> Recorder a'
cmap = (a -> b) -> Recorder b -> Recorder a
forall a' a. (a' -> a) -> Recorder a -> Recorder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap

cmapWithSev :: (a -> b) -> Recorder (WithSeverity b) -> Recorder (WithSeverity a)
cmapWithSev :: forall a b.
(a -> b) -> Recorder (WithSeverity b) -> Recorder (WithSeverity a)
cmapWithSev a -> b
f = (WithSeverity a -> WithSeverity b)
-> Recorder (WithSeverity b) -> Recorder (WithSeverity a)
forall a' a. (a' -> a) -> Recorder a -> Recorder a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((a -> b) -> WithSeverity a -> WithSeverity b
forall a b. (a -> b) -> WithSeverity a -> WithSeverity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

cmapIO :: (a -> IO b) -> Recorder b -> Recorder a
cmapIO :: forall a b. (a -> IO b) -> Recorder b -> Recorder a
cmapIO a -> IO b
f Recorder{ forall (m :: * -> *). MonadIO m => b -> m ()
logger_ :: forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ :: forall (m :: * -> *). MonadIO m => b -> m ()
logger_ } =
  Recorder
    { logger_ :: forall (m :: * -> *). MonadIO m => a -> m ()
logger_ = (IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (a -> IO b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f) (a -> m b) -> (b -> m ()) -> a -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> m ()
forall (m :: * -> *). MonadIO m => b -> m ()
logger_ }

renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text
renderPrettyWithSeverity :: forall a. Pretty a => WithSeverity a -> Text
renderPrettyWithSeverity =
  (a -> Text) -> WithSeverity a -> Text
forall a. (a -> Text) -> WithSeverity a -> Text
renderWithSeverity a -> Text
forall a. Pretty a => a -> Text
renderPretty

renderWithSeverity :: (a -> Text) -> WithSeverity a -> Text
renderWithSeverity :: forall a. (a -> Text) -> WithSeverity a -> Text
renderWithSeverity a -> Text
f WithSeverity a
msgWithSev =
  Severity -> Text
renderSeverity (WithSeverity a -> Severity
forall msg. WithSeverity msg -> Severity
getSeverity WithSeverity a
msgWithSev) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
f (WithSeverity a -> a
forall msg. WithSeverity msg -> msg
getMsg WithSeverity a
msgWithSev)

renderPretty :: Pretty a => a -> Text
renderPretty :: forall a. Pretty a => a -> Text
renderPretty a
a =
  let
    docToText :: Doc ann -> Text
docToText = SimpleDocStream ann -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream ann -> Text)
-> (Doc ann -> SimpleDocStream ann) -> Doc ann -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions
  in
    Doc (ZonkAny 0) -> Text
forall {ann}. Doc ann -> Text
docToText (a -> Doc (ZonkAny 0)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
a)

renderWithTimestamp :: Text -> IO Text
renderWithTimestamp :: Text -> IO Text
renderWithTimestamp Text
msg = do
  t <- IO UTCTime
getCurrentTime
  let timeStamp = UTCTime -> Text
forall {t}. FormatTime t => t -> Text
utcTimeToText UTCTime
t
  pure $ "[" <> timeStamp <> "]" <> msg
  where
    utcTimeToText :: t -> Text
utcTimeToText t
utcTime = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> t -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%6QZ" t
utcTime

renderSeverity :: Severity -> Text
renderSeverity :: Severity -> Text
renderSeverity = \ case
  Severity
Debug -> Text
"[DEBUG]"
  Severity
Info -> Text
"[INFO]"
  Severity
Warning -> Text
"[WARNING]"
  Severity
Error -> Text
"[ERROR]"

toCologAction :: (MonadIO m, HasCallStack) => Recorder msg -> Colog.LogAction m msg
toCologAction :: forall (m :: * -> *) msg.
(MonadIO m, HasCallStack) =>
Recorder msg -> LogAction m msg
toCologAction (Recorder forall (m :: * -> *). MonadIO m => msg -> m ()
logger_) = (msg -> m ()) -> LogAction m msg
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
Colog.LogAction ((msg -> m ()) -> LogAction m msg)
-> (msg -> m ()) -> LogAction m msg
forall a b. (a -> b) -> a -> b
$ \msg
msg -> do
    msg -> m ()
forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ msg
msg

fromCologAction :: (HasCallStack) => Colog.LogAction IO msg -> Recorder msg
fromCologAction :: forall msg. HasCallStack => LogAction IO msg -> Recorder msg
fromCologAction (Colog.LogAction msg -> IO ()
logger_) = (forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder ((forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg)
-> (forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
forall a b. (a -> b) -> a -> b
$ \msg
msg -> do
    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
$ msg -> IO ()
logger_ msg
msg