{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module      : Colog.Polysemy.Formatting
-- Description : A Polysemy effect for logging using Co-Log.
--
-- Checklist for use:
--
--     1. Add `co-log-polysemy-formatting` to your `build-depends` in your .cabal file,
--     2. Turn on the OverloadedStrings language extension,
--     3. `import Colog.Polysemy.Formatting`
--     4. (optional) Add the 'HasCallStack' constrain to your `main` if it calls any logging functions directly,
--     5. Create a logging environment with 'newLogEnv', e.g. like this: @logEnvStderr <- newLogEnv stderr@
--     6. To create log messages from within the 'Sem' monad, add the @'WithLog' r@ constraint and then call any of the logging functions: 'logDebug', 'logInfo', 'logWarning', 'logError', or 'logException'.
--        Note that these take a "Formatting" formatter, not a String/Text/etc.
--        But note also that they can still take a string literal, which will be transformed into a formatter using OverloadedStrings.
--     7. (optional) When interpreting your program, add a call to 'filterLogs' to e.g. filter out Debug messages for a production build,
--     8. call 'addThreadAndTimeToLog',
--     9. call 'runLogAction', including a call to 'renderThreadTimeMessage' or 'Color.Polysemy.Formatting.Render.renderThreadTimeMessageShort' with the LogEnv you created in step 4, e.g. like this: @runLogAction (logTextStderr & cmap (renderThreadTimeMessage logEnvStderr))@.
--
-- Example of usage (this is a copy of example/Main.hs, which you can compile and run for yourself):
--
-- > -- Required for formatting
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > -- Required for Polysemy
-- > {-# LANGUAGE DataKinds #-}
-- > {-# LANGUAGE FlexibleContexts #-}
-- > {-# LANGUAGE GADTs #-}
-- >
-- > -- Required for co-log-polysemy-formatting.
-- > -- This should re-export everything you need for logging.
-- > import Colog.Polysemy.Formatting
-- >
-- > -- Other imports for this example
-- > import Data.Function ((&))
-- > import Formatting
-- > import Polysemy
-- > import Polysemy.Async
-- > import System.IO (stderr)
-- >
-- > -- main needs the 'HasCallStack' constraint for log functions to know where they were called from
-- > main :: HasCallStack => IO ()
-- > main = do
-- >   -- Set up a logging environment, logging to stderr and using the local timezone
-- >   logEnvStderr <- newLogEnv stderr
-- >
-- >   (do
-- >     -- This debug message will show up only if 'debugMode' is True
-- >     logDebug "MyApp version 0.1.0.0"
-- >
-- >     -- Run our Polysemy program
-- >     program
-- >     )
-- >       -- Set the level of logging we want (for more control see 'filterLogs')
-- >       & setLogLevel Debug
-- >
-- >       -- This lets us log the thread id and message timestamp with each log message
-- >       -- It transforms the 'Log Message' effect into a 'Log ThreadTimeMessage' effect.
-- >       & addThreadAndTimeToLog
-- >
-- >       -- If you are using the 'Async' effect then interpret it here, after adding the thread and time,
-- >       -- but before running the log action.
-- >       & asyncToIO
-- >
-- >       -- Log to stderr, using our logging environment
-- >       & runLogAction (logTextStderr & cmap (renderThreadTimeMessage logEnvStderr))
-- >
-- >       & runM
-- >
-- > -- The 'WithLog r' constraint expands to '(HasCallStack, Member (Log Message) r)'
-- > program :: (WithLog r, Members '[Async, Embed IO] r) => Sem r ()
-- > program = do
-- >   -- This concurrency is just here to demonstrate that it is possible.
-- >   -- It isn't required.
-- >   _ <- sequenceConcurrently $
-- >     replicate 10 asyncProg
-- >     <> [logError ("Error message: '" % accessed fst text <> "', number: " % accessed snd int) ("It's all broken!", 17 :: Int)]
-- >     <> replicate 10 asyncProg
-- >   pure ()
-- >   where
-- >     asyncProg = do
-- >       logInfo "Hello, logging!"
-- >       embed $ fprintLn "Hello, logging!"
--
-- The above produces this:
--
-- <<example/output.png example program output>>
module Colog.Polysemy.Formatting
  (
  -- * Creating log messages
    WithLog
  , WithLog'
  , logDebug
  , logInfo
  , logWarning
  , logError
  , logException

  -- * Interpreting the log
  , newLogEnv
  , ignoreLog
  , filterLogs
  , setLogLevel
  , addThreadAndTimeToLog
  , renderThreadTimeMessage

  -- * Re-exports from other packages
  , HasCallStack
  , runLogAction
  , logTextStdout
  , logTextStderr
  , logTextHandle
  , cmap
  , Severity(..)
  , Msg(..)
  ) where

import Prelude hiding (log)

import Colog (Msg(..), Severity(..), cmap)
import Colog.Actions (logTextHandle, logTextStderr, logTextStdout)
import Colog.Polysemy (Log(..), runLogAction)
import qualified Colog.Polysemy as Colog
import Control.Category ((>>>))
import Control.Exception (Exception, displayException)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Formatting
import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)
import Polysemy

import Colog.Polysemy.Formatting.LogEnv (newLogEnv)
import Colog.Polysemy.Formatting.Render (renderThreadTimeMessage)
import Colog.Polysemy.Formatting.ThreadTimeMessage (addThreadAndTimeToLog, HasSeverity(..))
import Colog.Polysemy.Formatting.WithLog (WithLog, WithLog')

-- | Log a message with an explicit severity.
-- You probably don't want to use this directly.
-- Use 'logInfo', 'logError', etc. instead.
log :: WithLog r => Severity -> Format (Sem r ()) a -> a
log :: Severity -> Format (Sem r ()) a -> a
log Severity
sev Format (Sem r ()) a
m = (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$
  Format (Sem r ()) a -> (Builder -> Sem r ()) -> a
forall r a. Format r a -> (Builder -> r) -> a
runFormat Format (Sem r ()) a
m
    ((Builder -> Sem r ()) -> a) -> (Builder -> Sem r ()) -> a
forall a b. (a -> b) -> a -> b
$ Msg Severity -> Sem r ()
forall msg (r :: [(* -> *) -> * -> *]).
Member (Log msg) r =>
msg -> Sem r ()
Colog.log
    (Msg Severity -> Sem r ())
-> (Builder -> Msg Severity) -> Builder -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Severity -> CallStack -> Text -> Msg Severity
forall sev. sev -> CallStack -> Text -> Msg sev
Msg Severity
sev CallStack
HasCallStack => CallStack
callStack
    (Text -> Msg Severity)
-> (Builder -> Text) -> Builder -> Msg Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict
    (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TLB.toLazyText

-- | Log a debug message in the given format.
logDebug :: WithLog r => Format (Sem r ()) a -> a
logDebug :: Format (Sem r ()) a -> a
logDebug = (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Format (Sem r ()) a -> a)
 -> Format (Sem r ()) a -> a)
-> (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a
-> a
forall a b. (a -> b) -> a -> b
$ Severity -> Format (Sem r ()) a -> a
forall (r :: [(* -> *) -> * -> *]) a.
WithLog r =>
Severity -> Format (Sem r ()) a -> a
log Severity
Debug

-- | Log an info message in the given format.
logInfo :: WithLog r => Format (Sem r ()) a -> a
logInfo :: Format (Sem r ()) a -> a
logInfo = (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Format (Sem r ()) a -> a)
 -> Format (Sem r ()) a -> a)
-> (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a
-> a
forall a b. (a -> b) -> a -> b
$ Severity -> Format (Sem r ()) a -> a
forall (r :: [(* -> *) -> * -> *]) a.
WithLog r =>
Severity -> Format (Sem r ()) a -> a
log Severity
Info

-- | Log a warning in the given format.
logWarning :: WithLog r => Format (Sem r ()) a -> a
logWarning :: Format (Sem r ()) a -> a
logWarning = (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Format (Sem r ()) a -> a)
 -> Format (Sem r ()) a -> a)
-> (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a
-> a
forall a b. (a -> b) -> a -> b
$ Severity -> Format (Sem r ()) a -> a
forall (r :: [(* -> *) -> * -> *]) a.
WithLog r =>
Severity -> Format (Sem r ()) a -> a
log Severity
Warning

-- | Log an error in the given format.
logError :: WithLog r => Format (Sem r ()) a -> a
logError :: Format (Sem r ()) a -> a
logError = (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Format (Sem r ()) a -> a)
 -> Format (Sem r ()) a -> a)
-> (HasCallStack => Format (Sem r ()) a -> a)
-> Format (Sem r ()) a
-> a
forall a b. (a -> b) -> a -> b
$ Severity -> Format (Sem r ()) a -> a
forall (r :: [(* -> *) -> * -> *]) a.
WithLog r =>
Severity -> Format (Sem r ()) a -> a
log Severity
Error

-- | Log the exception as an error.
logException :: (WithLog r, Exception e) => e -> Sem r ()
logException :: e -> Sem r ()
logException = Sem r () -> Sem r ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Sem r () -> Sem r ()) -> (e -> Sem r ()) -> e -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format (Sem r ()) (String -> Sem r ()) -> String -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) a.
WithLog r =>
Format (Sem r ()) a -> a
logError Format (Sem r ()) (String -> Sem r ())
forall r. Format r (String -> r)
string (String -> Sem r ()) -> (e -> String) -> e -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall e. Exception e => e -> String
displayException

-- | Interpret the 'Log' effect by completely ignoring all log messages.
ignoreLog :: Sem (Log msg ': r) a -> Sem r a
ignoreLog :: Sem (Log msg : r) a -> Sem r a
ignoreLog = (forall x (rInitial :: [(* -> *) -> * -> *]).
 Log msg (Sem rInitial) x -> Sem r x)
-> Sem (Log msg : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Log msg (Sem rInitial) x -> Sem r x)
 -> Sem (Log msg : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Log msg (Sem rInitial) x -> Sem r x)
-> Sem (Log msg : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Log _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Remove any log messages that don't pass the given predicate.
--
-- E.g: @filterLogs ((<) Info . msgSeverity)@ will remove any logs that are 'Debug' or 'Info' severity, leaving only 'Warning's and 'Error's.
filterLogs
  :: Member (Log msg) r
  => (msg -> Bool)
  -> Sem (Log msg ': r) a
  -> Sem r a
filterLogs :: (msg -> Bool) -> Sem (Log msg : r) a -> Sem r a
filterLogs msg -> Bool
f = (forall x (rInitial :: [(* -> *) -> * -> *]).
 Log msg (Sem rInitial) x -> Sem r x)
-> Sem (Log msg : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Log msg (Sem rInitial) x -> Sem r x)
 -> Sem (Log msg : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Log msg (Sem rInitial) x -> Sem r x)
-> Sem (Log msg : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Log msg -> if msg -> Bool
f msg
msg
    then msg -> Sem r ()
forall msg (r :: [(* -> *) -> * -> *]).
Member (Log msg) r =>
msg -> Sem r ()
Colog.log msg
msg
    else () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Only show logs that are this log level or higher (lower according to the Ord instance for 'Severity').
--
-- E.g: @setLogLevel Debug@ will show all logs, whereas
-- @setLogLevel Warning@ will show only warnings and errors.
setLogLevel
  :: ( HasSeverity msg
     , Member (Log msg) r
     )
  => Severity
  -> Sem (Log msg ': r) a
  -> Sem r a
setLogLevel :: Severity -> Sem (Log msg : r) a -> Sem r a
setLogLevel Severity
level = (msg -> Bool) -> Sem (Log msg : r) a -> Sem r a
forall msg (r :: [(* -> *) -> * -> *]) a.
Member (Log msg) r =>
(msg -> Bool) -> Sem (Log msg : r) a -> Sem r a
filterLogs (msg -> Severity
forall msg. HasSeverity msg => msg -> Severity
getSeverity (msg -> Severity) -> (Severity -> Bool) -> msg -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
(<=) Severity
level)