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 qualified Control.Exception.Safe as Safe
import Data.Foldable ( traverse_ )
import Data.Default
import Control.Monad
import qualified Control.Monad.Catch as Catch
import Control.Monad.Trans.Control ( MonadBaseControl
( restoreM
, liftBaseWith
, StM
)
)
import Control.Monad.Base ( MonadBase() )
import Debug.Trace
logMsg :: (NFData m, Member (Logs m) e) => m -> Eff e ()
logMsg (force -> msg) = logMsgs [msg]
logMsgs
:: ( Traversable f
, MonadPlus f
, NFData1 f
, NFData (f m)
, NFData m
, Member (Logs m) e
)
=> f m
-> Eff e ()
logMsgs !msgs = rnf1 msgs `seq` do
f <- send AskLogFilter
send
(LogMsgs
(do
m <- msgs
maybe mzero (return . force) (f m)
)
)
mapLogMessages
:: forall m r b
. (NFData m, Member (Logs m) r)
=> (m -> m)
-> Eff r b
-> Eff r b
mapLogMessages f eff = do
old <- send AskLogFilter
interpose return (go (fmap f . old)) eff
where
go :: (m -> Maybe m) -> Logs m a -> Arr r a b -> Eff r b
go t AskLogFilter k = k t
go _ (LogMsgs ms) k = logMsgs ms >>= k
filterLogMessages
:: forall m r b
. (NFData m, Member (Logs m) r)
=> (m -> Bool)
-> Eff r b
-> Eff r b
filterLogMessages predicate eff = do
old <- send AskLogFilter
interpose return (go (\m -> if predicate m then old m else Nothing)) eff
where
go :: (m -> Maybe m) -> Logs m a -> Arr r a b -> Eff r b
go t AskLogFilter k = k t
go _ (LogMsgs ms) k = logMsgs ms >>= k
traverseLogMessages
:: forall m r h b
. ( Member (Logs m) r
, Monad h
, Lifted h r
, Member (Reader (LogWriter m h)) r
)
=> (forall f . (MonadPlus f, Traversable f, NFData1 f) => f m -> h (f m))
-> Eff r b
-> Eff r b
traverseLogMessages f = changeLogWriter
(\msgs -> do
lw <- ask
msgs' <- lift (f msgs)
lift (runLogWriter lw msgs')
)
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
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 ()
go AskLogFilter k = k (const Nothing)
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 ()
go AskLogFilter k = k pure
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 LogWriterReader message writerM =
Reader (LogWriter message writerM)
foldingLogWriter
:: ( forall f
. (MonadPlus f, Traversable f, NFData1 f)
=> f message
-> writerM ()
)
-> LogWriter message writerM
foldingLogWriter = LogWriter
writeAllLogMessages
:: (NFData1 f, MonadPlus f, Traversable f, Applicative writerM)
=> LogWriter message writerM
-> f message
-> writerM ()
writeAllLogMessages = runLogWriter
singleMessageLogWriter
:: (Applicative writerM)
=> (message -> writerM ())
-> LogWriter message writerM
singleMessageLogWriter writeMessage = foldingLogWriter (traverse_ writeMessage)
multiMessageLogWriter
:: (Applicative writerM)
=> (((message -> writerM ()) -> writerM ()) -> writerM ())
-> LogWriter message writerM
multiMessageLogWriter withMessageWriter =
foldingLogWriter (\xs -> withMessageWriter (\writer -> traverse_ writer xs))
askLogWriter
:: forall m h r . (Member (Reader (LogWriter m h)) r) => Eff r (LogWriter m h)
askLogWriter = ask
type HasLogWriter message logWriterMonad effects =
( Member (Reader (LogWriter message logWriterMonad)) effects
, Member (Logs message) effects
, NFData message
, Monad logWriterMonad
, Lifted logWriterMonad effects
)
data Logs m v where
AskLogFilter
:: (NFData m) => Logs m (m -> Maybe m)
LogMsgs
:: (Traversable f, MonadPlus f, NFData1 f, NFData m, NFData (f m))
=> f m -> Logs m ()
runLogsFiltered
:: forall m h e b
. (NFData m, Applicative h, Lifted h e, Member (LogWriterReader m h) e)
=> (m -> Maybe m)
-> Eff (Logs m ': e) b
-> Eff e b
runLogsFiltered f = handle_relay return (go f)
where
go :: (m -> Maybe m) -> Logs m a -> Arr e a c -> Eff e c
go lt AskLogFilter k = k lt
go _lt (LogMsgs ms) k = do
logWrtr <- ask
lift (writeAllLogMessages logWrtr (force ms))
k ()
runLogs
:: forall m h e b
. (Applicative h, Lifted h e, Member (LogWriterReader m h) e, NFData m)
=> Eff (Logs m ': e) b
-> Eff e b
runLogs = runLogsFiltered pure
writeLogs
:: forall message writerM r a
. (Applicative writerM, Lifted writerM r, NFData message)
=> LogWriter message writerM
-> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a
-> Eff r a
writeLogs w = runReader w . runLogs
writeLogsFiltered
:: forall message writerM r a
. (Applicative writerM, Lifted writerM r, NFData message)
=> (message -> Maybe message)
-> LogWriter message writerM
-> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a
-> Eff r a
writeLogsFiltered f w = runReader w . runLogsFiltered f
instance
( MonadBase m m
, Lifted m r
, NFData l
, 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
lf <- send AskLogFilter
raise (raise (liftBaseWith (\runInBase -> f (runInBase . writeLogsFiltered lf l))))
restoreM = raise . raise . restoreM
instance (NFData l, Lifted m e, Catch.MonadThrow (Eff e))
=> Catch.MonadThrow (Eff (Logs l ': LogWriterReader l m ': e)) where
throwM exception = raise (raise (Catch.throwM exception))
instance (NFData l, Applicative m, Lifted m e, Catch.MonadCatch (Eff e))
=> Catch.MonadCatch (Eff (Logs l ': LogWriterReader l m ': e)) where
catch effect handler = do
logWriter <- ask @(LogWriter l m)
logFilter <- send AskLogFilter
let lower = writeLogsFiltered logFilter logWriter
nestedEffects = lower effect
nestedHandler exception = lower (handler exception)
raise (raise (Catch.catch nestedEffects nestedHandler))
instance (NFData l, Applicative m, Lifted m e, Catch.MonadMask (Eff e))
=> Catch.MonadMask (Eff (Logs l ': LogWriterReader l m ': e)) where
mask maskedEffect = do
logWriter <- ask @(LogWriter l m)
logFilter <- send AskLogFilter
let
lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a
lower = writeLogsFiltered logFilter logWriter
raise
(raise
(Catch.mask
(\nestedUnmask -> lower
(maskedEffect
( raise . raise . nestedUnmask . lower )
)
)
)
)
uninterruptibleMask maskedEffect = do
logWriter <- ask @(LogWriter l m)
logFilter <- send AskLogFilter
let
lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a
lower = writeLogsFiltered logFilter logWriter
raise
(raise
(Catch.uninterruptibleMask
(\nestedUnmask -> lower
(maskedEffect
( raise . raise . nestedUnmask . lower )
)
)
)
)
generalBracket acquire release use = do
logWriter <- ask @(LogWriter l m)
logFilter <- send AskLogFilter
let
lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a
lower = writeLogsFiltered logFilter logWriter
raise
(raise
(Catch.generalBracket
(lower acquire)
(((.).(.)) lower release)
(lower . use)
)
)