{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Control.Eff.Log ( Log
, LogM
, Logger
, stdoutLogger
, stderrLogger
, LogMessage(..)
, logE
, logM
, filterLog
, filterLog'
, runLogPure
, runLog
, runLogM
) where
import Control.Eff
import Control.Eff.Extend
import Control.Monad (when)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Char8
import Data.Function (fix)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import System.IO (stderr, stdout)
data Log l v where
Log :: l -> Log l ()
instance Monad m => Handle (Log l) r a (b -> (l -> b -> b) -> m (a,b)) where
handle step q (Log l) e append = step (q ^$ ()) e append >>=
\(x, ls) -> return (x, l `append` ls)
instance Monad m => Handle (Log l) r a ((l -> m c) -> m a) where
handle step q (Log l) action = step (q ^$ ()) action >>=
\x -> action l >> return x
instance ( MonadBase m m
, Lifted m r
, MonadBaseControl m (Eff r)
) => MonadBaseControl m (Eff (Log l ': r)) where
type StM (Eff (Log l ': r)) a = StM (Eff r) (a, [l])
liftBaseWith f = raise $ liftBaseWith $ \runInBase ->
f (runInBase . runLogPure)
restoreM x = do (a, ls :: [l]) <- raise (restoreM x)
mapM_ logE ls
return a
type Logger m l = l -> m ()
stdoutLogger :: (LogMessage l, MonadBase IO m) => Logger m l
stdoutLogger = liftBase . Char8.hPutStrLn stdout . toMsg
stderrLogger :: (LogMessage l, MonadBase IO m) => Logger m l
stderrLogger = liftBase . Char8.hPutStrLn stderr . toMsg
logE :: Member (Log l) r => l -> Eff r ()
logE = send . Log
runLogPure :: Eff (Log l ': r) a -> Eff r (a, [l])
runLogPure m = fix (handle_relay ret) m [] (:)
where
ret :: Monad m => a -> b -> (l -> b -> b) -> m (a, b)
ret l e _ = return (l, e)
runLog :: Lifted m r => Logger m l -> Eff (Log l ': r) a -> Eff r a
runLog logger m = fix (handle_relay ret) m (lift . logger)
where
ret :: Monad m => a -> (l -> m c) -> m a
ret a _ = return a
filterLog :: forall l r a. Member (Log l) r
=> (l -> Bool) -> Eff r a -> Eff r a
filterLog f = fix (respond_relay' h return)
where
h :: (Eff r b -> Eff r b) -> Arrs r v b -> Log l v -> Eff r b
h step q (Log l) = when (f l) (logE l) >>= \x -> step (q ^$ x)
filterLog' :: Member (Log l) r
=> (l -> Bool) -> proxy l -> Eff r a -> Eff r a
filterLog' predicate _ = filterLog predicate
data LogM m l v where
AskLogger :: LogM m l (Logger m l)
askLogger :: Member (LogM m l) r => Eff r (Logger m l)
askLogger = send AskLogger
logM :: (Member (LogM m l) r, Lifted m r) => l -> Eff r ()
logM l = do logger <- askLogger
lift (logger l)
runLogM :: Lifted m r => Logger m l -> Eff (LogM m l ': r) a -> Eff r a
runLogM logger m = fix (handle_relay ret) m logger
where
ret :: Monad m' => a -> Logger m l -> m' a
ret x _ = return x
instance Monad m => Handle (LogM m' l) r a (Logger m' l -> m a) where
handle step q AskLogger logger = step (q ^$ logger) logger
instance ( MonadBase m m
, Lifted m r
, MonadBaseControl m (Eff r)
) => MonadBaseControl m (Eff (LogM m l ': r)) where
type StM (Eff (LogM m l ': r)) a = StM (Eff r) a
liftBaseWith f = do l <- askLogger
raise $ liftBaseWith $ \runInBase ->
f (runInBase . runLogM l)
restoreM = raise . restoreM
class LogMessage l where
toMsg :: l -> ByteString
{-# MINIMAL toMsg #-}
instance LogMessage ByteString where
toMsg = id
instance LogMessage [Char] where
toMsg = Char8.pack
instance LogMessage Text where
toMsg = encodeUtf8