-- | A logging effect based on 'Control.Monad.Log.MonadLog'.
module Control.Eff.Log.Handler
(
-- * Logging Effect
Logs(..)
, logMsg
, interceptLogging
, foldLogMessages
, relogAsString
, captureLogs
, ignoreLogs
, handleLogsWith
, handleLogsLifted
, handleLogsWithLoggingTHandler
)
where
import Control.DeepSeq
import Control.Eff as Eff
import Control.Eff.Extend as Eff
import qualified Control.Eff.Lift as Eff
import qualified Control.Monad.Log as Log
import Data.Foldable ( traverse_ )
import Data.Kind ( )
import Data.Sequence ( Seq() )
import qualified Data.Sequence as Seq
-- | Logging effect type, parameterized by a log message type.
data Logs message a where
LogMsg :: message -> Logs message ()
-- | Log a message.
logMsg :: Member (Logs m) r => m -> Eff r ()
logMsg = send . LogMsg
-- | 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 a . Member (Logs m) r => (m -> Eff r ()) -> Eff r a -> Eff r a
interceptLogging interceptor = interpose return go
where
go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y
go (LogMsg m) k = do
interceptor m
k ()
-- | Intercept logging to change, add or remove log messages.
--
-- This is without side effects, hence faster than 'interceptLogging'.
foldLogMessages
:: forall r m a f
. (Foldable f, Member (Logs m) r)
=> (m -> f m)
-> Eff r a
-> Eff r a
foldLogMessages interceptor = interpose return go
where
go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y
go (LogMsg m) k = do
traverse_ logMsg (interceptor m)
k ()
-- | Capture all log messages in a 'Seq' (strict).
captureLogs
:: NFData message => Eff (Logs message ': r) a -> Eff r (a, Seq message)
captureLogs = Eff.handle_relay_s Seq.empty
(\logs result -> return (result, logs))
handleLogs
where
handleLogs
:: NFData message
=> Seq message
-> Logs message x
-> (Seq message -> Arr r x y)
-> Eff r y
handleLogs !logs (LogMsg !m) k = k (force (logs Seq.:|> m)) ()
-- | Throw away all log messages.
ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a
ignoreLogs = Eff.handle_relay return handleLogs
where
handleLogs :: Logs m x -> Arr r x y -> Eff r y
handleLogs (LogMsg _) k = k ()
-- | Handle a 'Logs' effect with a message that has a 'Show' instance by
-- **re-logging** each message applied to 'show'.
relogAsString
:: forall m e a
. (Show m, Member (Logs String) e)
=> Eff (Logs m ': e) a
-> Eff e a
relogAsString = handleLogsWith (logMsg . show)
-- | Apply a function that returns an effect to each log message.
handleLogsWith
:: forall message e a
. (message -> Eff e ())
-> Eff (Logs message ': e) a
-> Eff e a
handleLogsWith h = handle_relay return $ \(LogMsg m) k -> h m >>= k
-- | Handle the 'Logs' effect with a monadic call back function (strict).
handleLogsLifted
:: forall m r message a
. (NFData message, Monad m, SetMember Eff.Lift (Eff.Lift m) r)
=> (message -> m ())
-> Eff (Logs message ': r) a
-> Eff r a
handleLogsLifted logMessageHandler = handleLogsWith go
where
go :: message -> Eff r ()
go m = Eff.lift (logMessageHandler (force m))
-- | Handle the 'Logs' effect using 'Log.LoggingT' 'Log.Handler's.
handleLogsWithLoggingTHandler
:: forall m r message a
. (Monad m, SetMember Eff.Lift (Eff.Lift m) r)
=> (forall b . (Log.Handler m message -> m b) -> m b)
-> Eff (Logs message ': r) a
-> Eff r a
handleLogsWithLoggingTHandler foldHandler =
handleLogsWith (Eff.lift . foldHandler . flip ($))