git.iko.soy/rowtype-yoga/purescript-native
on 2a4e404 help sign in
rowtype-yoga/purescript-native/src/Control/Monad/Logger.hs
72 lines 2.2 kB history raw
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-----------------------------------------------------------------------------
15{-# LANGUAGE FlexibleInstances #-}
16{-# LANGUAGE MultiParamTypeClasses #-}
17{-# LANGUAGE TypeFamilies #-}
19module Control.Monad.Logger where
21import Prelude ()
22import Prelude.Compat
24import Data.IORef
26import Control.Monad (ap)
27import Control.Monad.IO.Class
28import Control.Monad.Writer.Class
29import Control.Monad.Base (MonadBase(..))
30import Control.Monad.Trans.Control (MonadBaseControl(..))
32-- | A replacement for WriterT IO which uses mutable references.
33newtype Logger w a = Logger { runLogger :: IORef w -> IO a }
35-- | Run a Logger computation, starting with an empty log.
36runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
37runLogger' l = do
38 r <- newIORef mempty
39 a <- runLogger l r
40 w <- readIORef r
41 return (a, w)
43instance Functor (Logger w) where
44 fmap f (Logger l) = Logger $ \r -> fmap f (l r)
46instance (Monoid w) => Applicative (Logger w) where
47 pure = Logger . const . pure
48 (<*>) = ap
50instance (Monoid w) => Monad (Logger w) where
51 return = pure
52 Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r
54instance (Monoid w) => MonadIO (Logger w) where
55 liftIO = Logger . const
57instance (Monoid w) => MonadWriter w (Logger w) where
58 tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ())
59 listen l = Logger $ \r -> do
60 (a, w) <- liftIO (runLogger' l)
61 atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w))
62 pass l = Logger $ \r -> do
63 ((a, f), w) <- liftIO (runLogger' l)
64 atomicModifyIORef' r $ \w' -> (mappend w' (f w), a)
66instance (Monoid w) => MonadBase IO (Logger w) where
67 liftBase = liftIO
69instance (Monoid w) => MonadBaseControl IO (Logger w) where
70 type StM (Logger w) a = a
71 liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)
72 restoreM = return