|
| 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 |
0 commit comments