{-# LANGUAGE UndecidableInstances #-}
module Control.Eff.Log.Writer
(
LogWriter(..)
, LogWriterReader
, localLogWriterReader
, askLogWriter
, runLogWriterReader
, HandleLogWriter(..)
, LogWriterM(..)
, noOpLogWriter
, filteringLogWriter
, mappingLogWriter
, mappingLogWriterM
)
where
import Control.Eff
import Control.Eff.Extend
import Control.Eff.Log.Message
import Data.Default
import Data.Function ( fix )
import Control.Monad ( (>=>)
, when
)
import Control.Monad.Base ( MonadBase() )
import qualified Control.Monad.Catch as Catch
import Control.Monad.Trans.Control ( MonadBaseControl
( restoreM
, liftBaseWith
, StM
)
)
import Control.Eff.Writer.Strict ( Writer, tell, runListWriter )
import Data.Kind
import Data.Foldable (traverse_)
newtype LogWriter writerM = MkLogWriter
{ runLogWriter :: LogMessage -> LogWriterM writerM ()
}
instance Applicative (LogWriterM w) => Default (LogWriter w) where
def = MkLogWriter (const (pure ()))
runLogWriterReader :: LogWriter h -> Eff (LogWriterReader h ': e) a -> Eff e a
runLogWriterReader e m = fix (handle_relay (\x _ -> return x)) m e
askLogWriter
:: SetMember LogWriterReader (LogWriterReader h) e => Eff e (LogWriter h)
askLogWriter = send AskLogWriter
localLogWriterReader
:: forall h e a
. SetMember LogWriterReader (LogWriterReader h) e
=> (LogWriter h -> LogWriter h)
-> Eff e a
-> Eff e a
localLogWriterReader f m =
f
<$> askLogWriter
>>= fix (respond_relay @(LogWriterReader h) (\x _ -> return x)) m
data LogWriterReader h v where
AskLogWriter :: LogWriterReader h (LogWriter h)
instance Handle (LogWriterReader h) e a (LogWriter h -> k) where
handle k q AskLogWriter lw = k (q ^$ lw) lw
instance forall h m r. (MonadBase m m, LiftedBase m r)
=> MonadBaseControl m (Eff (LogWriterReader h ': r)) where
type StM (Eff (LogWriterReader h ': r)) a = StM (Eff r) a
liftBaseWith f = do
lf <- askLogWriter
raise (liftBaseWith (\runInBase -> f (runInBase . runLogWriterReader lf)))
restoreM = raise . restoreM
instance (LiftedBase m e, Catch.MonadThrow (Eff e))
=> Catch.MonadThrow (Eff (LogWriterReader h ': e)) where
throwM exception = raise (Catch.throwM exception)
instance (Applicative m, LiftedBase m e, Catch.MonadCatch (Eff e))
=> Catch.MonadCatch (Eff (LogWriterReader h ': e)) where
catch effect handler = do
lf <- askLogWriter
let lower = runLogWriterReader lf
nestedEffects = lower effect
nestedHandler exception = lower (handler exception)
raise (Catch.catch nestedEffects nestedHandler)
instance (Applicative m, LiftedBase m e, Catch.MonadMask (Eff e))
=> Catch.MonadMask (Eff (LogWriterReader h ': e)) where
mask maskedEffect = do
lf <- askLogWriter
let lower :: Eff (LogWriterReader h ': e) a -> Eff e a
lower = runLogWriterReader lf
raise
(Catch.mask
(\nestedUnmask -> lower (maskedEffect (raise . nestedUnmask . lower)))
)
uninterruptibleMask maskedEffect = do
lf <- askLogWriter
let lower :: Eff (LogWriterReader h ': e) a -> Eff e a
lower = runLogWriterReader lf
raise
(Catch.uninterruptibleMask
(\nestedUnmask -> lower (maskedEffect (raise . nestedUnmask . lower)))
)
generalBracket acquire release useIt = do
lf <- askLogWriter
let lower :: Eff (LogWriterReader h ': e) a -> Eff e a
lower = runLogWriterReader lf
raise
(Catch.generalBracket (lower acquire)
(((.) . (.)) lower release)
(lower . useIt)
)
class HandleLogWriter (writer :: Type -> Type) where
data family LogWriterM writer a
handleLogWriterEffect :: (Member writer e) => LogWriterM writer () -> Eff e ()
liftWriteLogMessage :: ( SetMember LogWriterReader (LogWriterReader writer) e
, Member writer e
)
=> LogMessage
-> Eff e ()
liftWriteLogMessage m = do
w <- askLogWriter
handleLogWriterEffect (runLogWriter w m)
instance HandleLogWriter (Lift IO) where
newtype instance LogWriterM (Lift IO) a = IOLogWriter { runIOLogWriter :: IO a }
deriving (Applicative, Functor, Monad)
handleLogWriterEffect = send . Lift . runIOLogWriter
instance HandleLogWriter (Writer LogMessage) where
newtype LogWriterM (Writer LogMessage) a = MkCaptureLogs { unCaptureLogs :: Eff '[Writer LogMessage] a }
deriving (Functor, Applicative, Monad)
handleLogWriterEffect =
traverse_ (tell @LogMessage) . snd . run . runListWriter . unCaptureLogs
noOpLogWriter :: Applicative (LogWriterM m) => LogWriter m
noOpLogWriter = def
filteringLogWriter :: Monad (LogWriterM e) => LogPredicate -> LogWriter e -> LogWriter e
filteringLogWriter p lw =
MkLogWriter (\msg -> when (p msg) (runLogWriter lw msg))
mappingLogWriter :: (LogMessage -> LogMessage) -> LogWriter e -> LogWriter e
mappingLogWriter f lw = MkLogWriter (runLogWriter lw . f)
mappingLogWriterM
:: Monad (LogWriterM e) => (LogMessage -> LogWriterM e LogMessage) -> LogWriter e -> LogWriter e
mappingLogWriterM f lw = MkLogWriter (f >=> runLogWriter lw)