-- | A logging effect based on 'Control.Monad.Log.MonadLog'.
module Control.Eff.Log.Handler
  ( logMsg
  , logMsgs
  , HasLogWriter
  , mapLogMessages
  , filterLogMessages
  , traverseLogMessages
  , changeLogWriter
  , ignoreLogs
  , traceLogs
  , LogWriter()
  , LogWriterReader
  , foldingLogWriter
  , writeAllLogMessages
  , singleMessageLogWriter
  , multiMessageLogWriter
  , askLogWriter
  , Logs()
  , writeLogs
  , runLogs
  )
where

import           Control.DeepSeq
import           Control.Eff                   as Eff
import           Control.Eff.Extend
import           Control.Eff.Reader.Strict
import           Control.Eff.Lift              as Eff
import           Data.Foldable                  ( traverse_ )
import           Data.Default
import           Control.Monad
import           Control.Monad.Trans.Control    ( MonadBaseControl
                                                  ( restoreM
                                                  , liftBaseWith
                                                  , StM
                                                  )
                                                )
import           Control.Monad.Base             ( MonadBase() )
import           Debug.Trace

-- * Message Logging Effect

-- | Log a message. The message is reduced to normal form (strict).
logMsg :: (NFData m, Member (Logs m) e) => m -> Eff e ()
logMsg (force -> msg) = logMsgs [msg]

-- | Log a bunch of messages. This might be more efficient than calling 'logMsg'
-- multiple times.
-- The messages are reduced to normal form (strict).
logMsgs
  :: (Traversable f, MonadPlus f, NFData1 f, NFData m, Member (Logs m) e)
  => f m
  -> Eff e ()
logMsgs !msgs = rnf1 msgs `seq` send (LogMsgs msgs)

-- ** Filter and Transform Log Messages

-- | Map a pure function over log messages.
mapLogMessages
  :: forall m r b . (Member (Logs m) r) => (m -> m) -> Eff r b -> Eff r b
mapLogMessages f = interpose return go
 where
  go :: Logs m a -> Arr r a b -> Eff r b
  go (LogMsgs ms) k = logMsgs (fmap f ms) >>= k

-- | Keep only those messages, for which the predicate holds.
filterLogMessages
  :: forall m r b . (Member (Logs m) r) => (m -> Bool) -> Eff r b -> Eff r b
filterLogMessages predicate = interpose return go
 where
  go :: Logs m a -> Arr r a b -> Eff r b
  go (LogMsgs ms) k = logMsgs (mfilter predicate ms) >>= k

-- ** Filter and Transform Log Messages effectfully

-- | Map an 'Eff'ectful function over every bunch of log messages.
--
-- For example, to attach the current time to each log message:
--
-- > appendTimestamp
-- >  :: ( Member (Logs String) e
-- >     , Lifted IO e)
-- >  => Eff e a
-- >  -> Eff e a
-- > appendTimestamp = traverseLogMessages $ \ms -> do
-- >   now <- lift getCurrentTime
-- >   return (fmap (show now ++) ms)
traverseLogMessages
  :: forall m r b
   . (Member (Logs m) r)
  => (  forall f
      . (MonadPlus f, Traversable f, NFData1 f)
     => f m
     -> Eff r (f m)
     )
  -> Eff r b
  -> Eff r b
traverseLogMessages f = interpose return go
 where
  go :: Logs m a -> Arr r a b -> Eff r b
  go (LogMsgs ms) k = f ms >>= logMsgs >>= k

-- ** Change the Log Writer

-- | Change the way log messages are *written*.
-- Replaces the existing 'LogWriter' by a new one. The new 'LogWriter'
-- is constructed from a function that gets a /bunch/ of messages and
-- returns an 'Eff'ect.
-- That effect has a 'Reader' for the previous 'LogWriter' and 'Lift's
-- the log writer base monad.
changeLogWriter
  :: forall r m h a
   . (Monad h, Lifted h r, Member (Reader (LogWriter m h)) r)
  => (  forall f
      . (Traversable f, NFData1 f, MonadPlus f)
     => f m
     -> Eff '[Reader (LogWriter m h), Lift h] ()
     )
  -> Eff r a
  -> Eff r a
changeLogWriter interceptor =
  let replaceWriter old = LogWriter (runLift . runReader old . interceptor)
  in  local replaceWriter

-- * Handle Log Messages

-- | Throw away all log messages.
ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a
ignoreLogs = handle_relay return go
 where
  go :: Logs message v -> Arr r v a -> Eff r a
  go (LogMsgs _) k = k ()

-- | Trace all log messages using 'traceM'. The message value is
-- converted to 'String' using the given function.
traceLogs
  :: forall message r a
   . (message -> String)
  -> Eff (Logs message ': r) a
  -> Eff r a
traceLogs toString = handle_relay return go
 where
  go :: Logs message v -> Arr r v a -> Eff r a
  go (LogMsgs ms) k = traverse_ (traceM . toString) ms >> k ()

-- ** Log Message Writer Creation

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

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

-- | Type alias for the 'Reader' effect that writes logs
type LogWriterReader message writerM =
  Reader (LogWriter message writerM)

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

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

-- | 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)
  => (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)
  => (((message -> writerM ()) -> writerM ()) -> writerM ())
  -> LogWriter message writerM
multiMessageLogWriter withMessageWriter =
  foldingLogWriter (\xs -> withMessageWriter (\writer -> traverse_ writer xs))

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

-- ** Low-Level Log Message Sending

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

-- | This effect sends log messages.
-- The logs are not sent one-by-one, but always in batches of
-- containers that must be 'Traversable' and 'MonadPlus' instances.
-- Log messages are consumed by 'LogWriter's installed via
-- 'runLogs' or more high level functions like 'writeLogs'.
data Logs m v where
  LogMsgs
    :: (Traversable f, MonadPlus f, NFData1 f, NFData m)
    => f m
    -> Logs m ()

-- | Install 'Logs' handler that 'ask's for a 'LogWriter' for the
-- message type and applies the log writer to the messages.
runLogs
  :: forall m h e b
   . (Applicative h, Lifted h e, Member (LogWriterReader m h) e)
  => Eff (Logs m ': e) b
  -> Eff e b
runLogs = handle_relay return go
 where
  go :: Logs m a -> Arr e a b -> Eff e b
  go (LogMsgs ms) k = do
    logWrtr <- ask
    lift (writeAllLogMessages logWrtr ms)
    k ()

-- | Handle log message effects by a monadic action, e.g. an IO action
-- to send logs to the console output or a log-server.
-- The monadic log writer action is wrapped in a newtype called
-- 'LogWriter'.
--
-- Use the smart constructors below to create them, e.g.
-- 'foldingLogWriter', 'singleMessageLogWriter' or
-- 'mulitMessageLogWriter'.
writeLogs
  :: forall message writerM r a
   . (Applicative writerM, Lifted writerM r)
  => LogWriter message writerM
  -> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a
  -> Eff r a
writeLogs w = runReader w . runLogs

-- | This instance allows liftings of the 'Logs' effect, but only, if there is
-- a 'LogWriter' in effect.
instance
  ( MonadBase m m
  , Lifted m r
  , MonadBaseControl m (Eff r)
  )
  => MonadBaseControl m (Eff (Logs l ': LogWriterReader l m ': r)) where

    type StM (Eff (Logs l ': LogWriterReader l m ': r)) a =
      StM (Eff r) a

    liftBaseWith f = do
      l <- askLogWriter
      raise (raise (liftBaseWith (\runInBase -> f (runInBase . writeLogs l))))

    restoreM = raise . raise . restoreM