git.iko.soy/rowtype-yoga/purescript-native
on cd4c708 help sign in
rowtype-yoga/purescript-native/src/Control/Monad/Logger.hs
59 lines 1.8 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE TypeFamilies #-}
4-- |
5-- A replacement for WriterT IO which uses mutable references.
6--
7module Control.Monad.Logger where
9import Prelude.Compat
11import Control.Monad (ap)
12import Control.Monad.Base (MonadBase(..))
13import Control.Monad.IO.Class
14import Control.Monad.Trans.Control (MonadBaseControl(..))
15import Control.Monad.Writer.Class
17import Data.IORef
19-- | A replacement for WriterT IO which uses mutable references.
20newtype Logger w a = Logger { runLogger :: IORef w -> IO a }
22-- | Run a Logger computation, starting with an empty log.
23runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
24runLogger' l = do
25 r <- newIORef mempty
26 a <- runLogger l r
27 w <- readIORef r
28 return (a, w)
30instance Functor (Logger w) where
31 fmap f (Logger l) = Logger $ \r -> fmap f (l r)
33instance (Monoid w) => Applicative (Logger w) where
34 pure = Logger . const . pure
35 (<*>) = ap
37instance (Monoid w) => Monad (Logger w) where
38 return = pure
39 Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r
41instance (Monoid w) => MonadIO (Logger w) where
42 liftIO = Logger . const
44instance (Monoid w) => MonadWriter w (Logger w) where
45 tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ())
46 listen l = Logger $ \r -> do
47 (a, w) <- liftIO (runLogger' l)
48 atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w))
49 pass l = Logger $ \r -> do
50 ((a, f), w) <- liftIO (runLogger' l)
51 atomicModifyIORef' r $ \w' -> (mappend w' (f w), a)
53instance (Monoid w) => MonadBase IO (Logger w) where
54 liftBase = liftIO
56instance (Monoid w) => MonadBaseControl IO (Logger w) where
57 type StM (Logger w) a = a
58 liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)
59 restoreM = return