{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Logger where
import Prelude.Compat
import Control.Monad (ap)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.IO.Class
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Writer.Class
import Data.IORef
newtype Logger w a = Logger { runLogger :: IORef w -> IO a }
runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
runLogger' l = do
r <- newIORef mempty
a <- runLogger l r
w <- readIORef r
return (a, w)
instance Functor (Logger w) where
fmap f (Logger l) = Logger $ \r -> fmap f (l r)
instance (Monoid w) => Applicative (Logger w) where
pure = Logger . const . pure
(<*>) = ap
instance (Monoid w) => Monad (Logger w) where
return = pure
Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r
instance (Monoid w) => MonadIO (Logger w) where
liftIO = Logger . const
instance (Monoid w) => MonadWriter w (Logger w) where
tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ())
listen l = Logger $ \r -> do
(a, w) <- liftIO (runLogger' l)
atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w))
pass l = Logger $ \r -> do
((a, f), w) <- liftIO (runLogger' l)
atomicModifyIORef' r $ \w' -> (mappend w' (f w), a)
instance (Monoid w) => MonadBase IO (Logger w) where
liftBase = liftIO
instance (Monoid w) => MonadBaseControl IO (Logger w) where
type StM (Logger w) a = a
liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)
restoreM = return