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