@@ -0,0 +1,75 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Control.Monad.Logger
4+-- Author : Phil Freeman
5+-- License : MIT (http://opensource.org/licenses/MIT)
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | A replacement for WriterT IO which uses mutable references.
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE CPP #-}
16+{-# LANGUAGE FlexibleInstances #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
18+{-# LANGUAGE TypeFamilies #-}
19+
20+module Control.Monad.Logger where
21+
22+import Data.IORef
23+
24+#if __GLASGOW_HASKELL__ < 710
25+import Control.Applicative
26+#endif
27+import Control.Monad (ap)
28+import Control.Monad.IO.Class
29+import Control.Monad.Writer.Class
30+import Control.Monad.Base (MonadBase(..))
31+import Control.Monad.Trans.Control (MonadBaseControl(..))
32+
33+-- | A replacement for WriterT IO which uses mutable references.
34+data Logger w a = Logger { runLogger :: IORef w -> IO a }
35+
36+-- | Run a Logger computation, starting with an empty log.
37+runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
38+runLogger' l = do
39+ r <- newIORef mempty
40+ a <- runLogger l r
41+ w <- readIORef r
42+ return (a, w)
43+
44+instance Functor (Logger w) where
45+ fmap f (Logger l) = Logger $ \r -> fmap f (l r)
46+
47+instance (Monoid w) => Applicative (Logger w) where
48+ pure = Logger . const . pure
49+ (<*>) = ap
50+
51+instance (Monoid w) => Monad (Logger w) where
52+ return = pure
53+ Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r
54+
55+instance (Monoid w) => MonadIO (Logger w) where
56+ liftIO = Logger . const
57+
58+instance (Monoid w) => MonadWriter w (Logger w) where
59+ tell w = Logger $ \r -> modifyIORef' r (mappend w)
60+ listen l = Logger $ \r -> do
61+ (a, w) <- liftIO (runLogger' l)
62+ modifyIORef' r (mappend w)
63+ return (a, w)
64+ pass l = Logger $ \r -> do
65+ ((a, f), w) <- liftIO (runLogger' l)
66+ modifyIORef' r (mappend (f w))
67+ return a
68+
69+instance (Monoid w) => MonadBase IO (Logger w) where
70+ liftBase = liftIO
71+
72+instance (Monoid w) => MonadBaseControl IO (Logger w) where
73+ type StM (Logger w) a = a
74+ liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)
75+ restoreM = return