module Control.Eff.Log.Handler
(
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
data Logs message a where
LogMsg :: message -> Logs message ()
logMsg :: Member (Logs m) r => m -> Eff r ()
logMsg = send . LogMsg
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 ()
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 ()
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)) ()
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 ()
relogAsString
:: forall m e a
. (Show m, Member (Logs String) e)
=> Eff (Logs m ': e) a
-> Eff e a
relogAsString = handleLogsWith (logMsg . show)
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
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))
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 ($))