-- |
-- A replacement for WriterT IO which uses mutable references.
--
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)

-- | A replacement for WriterT IO which uses mutable references.
newtype Logger w a = Logger { forall w a. Logger w a -> IORef w -> IO a
runLogger :: IORef w -> IO a }

-- | Run a Logger computation, starting with an empty log.
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