{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module      : Colog.Polysemy.Formatting.ThreadTimeMessage
Description : A message type that includes ThreadId and a timestamp, wrapping a 'Message'.
-}
module Colog.Polysemy.Formatting.ThreadTimeMessage
  ( ThreadTimeMessage(..)
  , HasSeverity(..)
  , ttmSeverity
  , addThreadAndTimeToLog
  ) where

import Prelude hiding (log)

import Colog (Message, Msg(..), Severity(..))
import Colog.Polysemy (Log(..), log)
import Control.Concurrent (ThreadId, myThreadId)
import Data.Time (UTCTime, getCurrentTime)
import Polysemy

-- | A log message which wraps a 'Message', adding a 'ThreadId' and 'UTCTime' timestamp.
data ThreadTimeMessage = ThreadTimeMessage
  { ThreadTimeMessage -> ThreadId
ttmThreadId :: ThreadId
  , ThreadTimeMessage -> UTCTime
ttmTime     :: UTCTime
  , ThreadTimeMessage -> Message
ttmMsg      :: Message
  }

-- | Get the severity of the message.
ttmSeverity :: ThreadTimeMessage -> Severity
ttmSeverity :: ThreadTimeMessage -> Severity
ttmSeverity = Message -> Severity
forall sev. Msg sev -> sev
msgSeverity (Message -> Severity)
-> (ThreadTimeMessage -> Message) -> ThreadTimeMessage -> Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadTimeMessage -> Message
ttmMsg

class HasSeverity msg where
  getSeverity :: msg -> Severity

instance HasSeverity (Msg Severity) where
  getSeverity :: Message -> Severity
getSeverity = Message -> Severity
forall sev. Msg sev -> sev
msgSeverity

instance HasSeverity ThreadTimeMessage where
  getSeverity :: ThreadTimeMessage -> Severity
getSeverity = ThreadTimeMessage -> Severity
ttmSeverity

-- | Add the thread id and a timestamp to messages in the log.
-- This should be called /before/ any use of 'Polysemy.Async.asyncToIO', otherwise all log messages will have the same thread id.
-- It is best called /after/ any use of 'Colog.Polysemy.Formatting.filterLogs', otherwise you're needlessly processing messages that will never be logged (TODO: test this assertion is true).
addThreadAndTimeToLog
  :: Members
    '[ Embed IO
     , Log ThreadTimeMessage
     ] r
  => Sem (Log Message ': r) a
  -> Sem r a
addThreadAndTimeToLog :: Sem (Log Message : r) a -> Sem r a
addThreadAndTimeToLog = (forall x (rInitial :: EffectRow).
 Log Message (Sem rInitial) x -> Sem r x)
-> Sem (Log Message : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: EffectRow).
  Log Message (Sem rInitial) x -> Sem r x)
 -> Sem (Log Message : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Log Message (Sem rInitial) x -> Sem r x)
-> Sem (Log Message : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Log msg -> do
    ThreadId
threadId <- IO ThreadId -> Sem r ThreadId
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO ThreadId
myThreadId
    UTCTime
time <- IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO UTCTime
getCurrentTime
    ThreadTimeMessage -> Sem r ()
forall msg (r :: EffectRow). Member (Log msg) r => msg -> Sem r ()
log (ThreadTimeMessage -> Sem r ()) -> ThreadTimeMessage -> Sem r ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> UTCTime -> Message -> ThreadTimeMessage
ThreadTimeMessage ThreadId
threadId UTCTime
time Message
msg