{-# LANGUAGE ImplicitParams #-}

-- | A logging effect based on 'Control.Monad.Log.MonadLog'.
module Control.Eff.Log.Handler
  ( logMsg
  , logMsgs
  , LogsM
  , Logs
  , handleLogs
  , ignoreLogs
  , mapLogMessages
  , filterLogMessages
  , interceptLogging
  , HasLogWriter
  , HasLogWriterIO
  , LogWriter()
  , writeAllLogMessages
  , foldingLogWriter
  , singleMessageLogWriter
  , multiMessageLogWriter
  , HasLogWriterProxy
  , LogWriterProxy(..)
  , usingLogWriterProxy
  , logWriterProxy
  , askLogWriter
  )
where

import           Control.DeepSeq
import           Control.Eff                   as Eff
import           Control.Eff.Reader.Strict
import           Control.Eff.Lift              as Eff
import           Data.Foldable                  ( traverse_, toList )
import           Data.Kind
import           Data.Functor.Identity
import           GHC.Stack
import           Data.Default

-- | A function that takes a log message and returns an effect that
-- /logs/ the message.
newtype LogWriter message writerM =
  LogWriter
  { runLogWriter
      :: forall f. (HasCallStack, Traversable f, Foldable f, Functor f)
      => f message
      -> writerM ()
  }

instance Applicative w => Default (LogWriter m w) where
  def = LogWriter (const (pure ()))

-- | Efficiently apply the 'LogWriter' to a 'Foldable' container of log
-- messages.
writeAllLogMessages
  :: (Foldable f, Functor f, Traversable f, Applicative writerM, HasCallStack)
  => LogWriter message writerM -> f message -> writerM ()
writeAllLogMessages = runLogWriter

-- | Create a 'LogWriter' from a function that can write
-- a 'Foldable' container.
foldingLogWriter
  :: (forall f. (Foldable f, Traversable f, HasCallStack) => f message -> writerM ())
  -> LogWriter message writerM
foldingLogWriter = LogWriter

-- | Create a 'LogWriter' from a function that is applied to each
-- individual log message. NOTE: This is probably the simplest,
-- but also the most inefficient and annoying way to make
-- a 'LogWriter'. Better use 'foldingLogWriter' or even
-- 'multiMessageLogWriter'.
singleMessageLogWriter
  :: (Applicative writerM, HasCallStack)
  => (message -> writerM ())
  -> LogWriter message writerM
singleMessageLogWriter writeMessage =
  foldingLogWriter (traverse_ writeMessage)

-- | Create a 'LogWriter' from a function that is applied to each
-- individual log message. Don't be scared by the type signature,
-- here is an example file appender that re-opens the log file
-- everytime a bunch of log messages are written:
--
-- > fileAppender fn = multiMessageLogWriter
-- >   (\writeLogMessageWith ->
-- >      withFile fn AppendMode (writeLogMessageWith . hPutStrLn))
--
multiMessageLogWriter
  :: (Applicative writerM, HasCallStack)
  => (((message -> writerM ()) -> writerM ()) -> writerM ())
  -> LogWriter message writerM
multiMessageLogWriter withMessageWriter =
  foldingLogWriter
    (\xs -> withMessageWriter (\writer -> traverse_ writer xs))

-- | Logging effect type, parameterized by a log message type. This is a reader
-- for a 'LogWriter'.
type LogsM message writerM = Reader (LogWriter message writerM)

-- | The logging effect on IO.
type Logs message = LogsM message IO

-- | A constraint that combines constraints for logging into any
-- log writer monad.
type HasLogWriter message logWriterMonad effects =
  ( Member (LogsM message logWriterMonad) effects
  , NFData message
  , Monad logWriterMonad
  , HasLogWriterProxy logWriterMonad
  , Lifted logWriterMonad effects )

-- | A constraint that combines constraints for IO based logging.
type HasLogWriterIO message effects =
  ( Member (Logs message) effects
  , NFData message
  , HasLogWriterProxy IO
  , Lifted IO effects )

-- | Type constraint alias for the implicit 'LogWriterProxy'
type HasLogWriterProxy m = ( ?logWriterProxy :: LogWriterProxy m )

-- | A proxy type to carry the 'LogWriter' effects.
data LogWriterProxy (e :: Type -> Type) = LogWriterProxy

-- | Set the implicit parameter defined in 'HasLogWriterProxy' for function
-- applications like 'logMsg'
usingLogWriterProxy
  :: forall e r a
  . LogWriterProxy e
  -> (HasLogWriterProxy e => Eff r a) -> Eff r a
usingLogWriterProxy px e = let ?logWriterProxy = px in e

-- | Return the current 'LogWriterProxy'
logWriterProxy :: HasLogWriterProxy e => LogWriterProxy e
logWriterProxy = ?logWriterProxy

-- | Get the current 'LogWriter'
askLogWriter :: forall m h r . (HasLogWriter m h r) => Eff r (LogWriter m h)
askLogWriter = ask

-- | Log a message.
logMsg :: (NFData m, HasLogWriter m h r) => m -> Eff r ()
logMsg !(force -> m) = do
  lw <- askLogWriter
  lift (runLogWriter lw (Identity m))

-- | Log a bunch of messages. This might be more efficient than calling 'logMsg'
-- multiple times.
logMsgs :: (NFData (f m), HasLogWriter m h r, Functor f, Traversable f, Foldable f) => f m -> Eff r ()
logMsgs !(force -> m) = do
  lw <- askLogWriter
  lift (runLogWriter lw m)

-- | Change, add or remove log messages and perform arbitrary actions upon
-- intercepting a log message.
--
-- Requirements:
--
--   * All log meta data for typical prod code can be added without
--     changing much of the code
--
--   * Add timestamp to a log messages of a sub-computation.
--
--   * Write some messages to a file.
--
--   * Log something extra, e.g. runtime memory usage in load tests
--
-- Approach: Install a callback that sneaks into to log message
-- sending/receiving, to intercept the messages and execute some code and then
-- return a new message.
interceptLogging
  :: forall r m h a
   . (HasLogWriter m h r)
  => (m -> Eff '[LogsM m h, Lift h] ())
  -> (HasLogWriterProxy h => Eff r a)
  -> Eff r a
interceptLogging interceptor  =
  let replaceWriter old =
        multiMessageLogWriter
          ($ (runLift . runReader old . interceptor))
  in local replaceWriter

-- | Map a pure function over log messages.
mapLogMessages
  :: forall m h r a
   . (HasLogWriter m h r)
  => (m -> m)
  -> (HasLogWriterProxy h => Eff r a)
  -> Eff r a
mapLogMessages f =
  local @(LogWriter m h)
    (\(LogWriter old) ->
      LogWriter (\xs ->
        old (fmap f xs)))

-- | Filter which messages are handled.
filterLogMessages
  :: forall r m h a
   . (HasLogWriter m h r, HasCallStack)
  => (m -> Bool)
  -> (HasLogWriterProxy h => Eff r a)
  -> Eff r a
filterLogMessages predicate =
  local
    @(LogWriter m h)
    (\(LogWriter old) ->
      LogWriter (old . filter predicate . toList))

-- | Define the the 'LogWriter' callback and set the 'HasLogWriterProxy'
-- constraint in the given log writer action. This assumes that the monad used
-- is 'Lift'ed to @r@.
handleLogs
  :: forall message writerM r a
   . (Lifted writerM r)
  => LogWriter message writerM
  -> (HasLogWriterProxy writerM => Eff (LogsM message writerM ': r) a)
  -> Eff r a
handleLogs lw e =
  usingLogWriterProxy (LogWriterProxy @writerM) (runReader lw e)

-- | Throw away all log messages.
ignoreLogs
  :: forall message m r a
  . (Lifted m r, Applicative m)
  => (HasLogWriterProxy m => Eff (LogsM message m ': r) a)
  -> Eff r a
ignoreLogs = handleLogs def