Control/Monad/RWS.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Monad.RWS
   4 -- Copyright   :  (c) Andy Gill 2001,
   5 --                (c) Oregon Graduate Institute of Science and Technology, 2001
   6 -- License     :  BSD-style (see the file libraries/core/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  non-portable ( requires mulit-parameter type classes,
  11 --                               requires functional dependencies )
  12 --
  13 -- Declaration of the MonadRWS class.
  14 --
  15 --        Inspired by the paper
  16 --        \em{Functional Programming with Overloading and
  17 --            Higher-Order Polymorphism},
  18 --          \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
  19 --                Advanced School of Functional Programming, 1995.}
  20 -----------------------------------------------------------------------------
  21
  22 module Control.Monad.RWS (
  23         RWS(..),
  24         runRWS,
  25         evalRWS,
  26         execRWS,
  27         mapRWS,
  28         withRWS,
  29         RWST(..),
  30         runRWST,
  31         evalRWST,
  32         execRWST,
  33         mapRWST,
  34         withRWST,
  35         module Control.Monad,
  36         module Control.Monad.Fix,
  37         module Control.Monad.Trans,
  38         module Control.Monad.Reader,
  39         module Control.Monad.Writer,
  40         module Control.Monad.State,
  41   ) where
  42
  43 import Prelude
  44
  45 import Control.Monad
  46 import Control.Monad.Monoid
  47 import Control.Monad.Fix
  48 import Control.Monad.Trans
  49 import Control.Monad.Reader
  50 import Control.Monad.Writer
  51 import Control.Monad.State
  52
  53
  54 newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
  55
  56 instance Functor (RWS r w s) where
  57         fmap f m = RWS $ \r s -> let
  58                 (a, s', w) = runRWS m r s
  59                 in (f a, s', w)
  60
  61 instance (Monoid w) => Monad (RWS r w s) where
  62         return a = RWS $ \_ s -> (a, s, mempty)
  63         m >>= k  = RWS $ \r s -> let
  64                 (a, s',  w)  = runRWS m r s
  65                 (b, s'', w') = runRWS (k a) r s'
  66                 in (b, s'', w `mappend` w')
  67
  68 instance (Monoid w) => MonadFix (RWS r w s) where
  69         mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
  70
  71 instance (Monoid w) => MonadReader r (RWS r w s) where
  72         ask       = RWS $ \r s -> (r, s, mempty)
  73         local f m = RWS $ \r s -> runRWS m (f r) s
  74
  75 instance (Monoid w) => MonadWriter w (RWS r w s) where
  76         tell   w = RWS $ \_ s -> ((), s, w)
  77         listen m = RWS $ \r s -> let
  78                 (a, s', w) = runRWS m r s
  79                 in ((a, w), s', w)
  80         pass   m = RWS $ \r s -> let
  81                 ((a, f), s', w) = runRWS m r s
  82                 in (a, s', f w)
  83
  84 instance (Monoid w) => MonadState s (RWS r w s) where
  85         get   = RWS $ \_ s -> (s, s, mempty)
  86         put s = RWS $ \_ _ -> ((), s, mempty)
  87
  88
  89 evalRWS :: RWS r w s a -> r -> s -> (a, w)
  90 evalRWS m r s = let
  91     (a, _, w) = runRWS m r s
  92     in (a, w)
  93
  94 execRWS :: RWS r w s a -> r -> s -> (s, w)
  95 execRWS m r s = let
  96     (_, s', w) = runRWS m r s
  97     in (s', w)
  98
  99 mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
 100 mapRWS f m = RWS $ \r s -> f (runRWS m r s)
 101
 102 withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
 103 withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
 104
 105
 106 newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
 107
 108 instance (Monad m) => Functor (RWST r w s m) where
 109         fmap f m = RWST $ \r s -> do
 110                 (a, s', w) <- runRWST m r s
 111                 return (f a, s', w)
 112
 113 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
 114         return a = RWST $ \_ s -> return (a, s, mempty)
 115         m >>= k  = RWST $ \r s -> do
 116                 (a, s', w)  <- runRWST m r s
 117                 (b, s'',w') <- runRWST (k a) r s'
 118                 return (b, s'', w `mappend` w')
 119         fail msg = RWST $ \_ _ -> fail msg
 120
 121 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
 122         mzero       = RWST $ \_ _ -> mzero
 123         m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
 124
 125 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
 126         mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
 127
 128 instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
 129         ask       = RWST $ \r s -> return (r, s, mempty)
 130         local f m = RWST $ \r s -> runRWST m (f r) s
 131
 132 instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
 133         tell   w = RWST $ \_ s -> return ((),s,w)
 134         listen m = RWST $ \r s -> do
 135                 (a, s', w) <- runRWST m r s
 136                 return ((a, w), s', w)
 137         pass   m = RWST $ \r s -> do
 138                 ((a, f), s', w) <- runRWST m r s
 139                 return (a, s', f w)
 140
 141 instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
 142         get   = RWST $ \_ s -> return (s, s, mempty)
 143         put s = RWST $ \_ _ -> return ((), s, mempty)
 144
 145 instance (Monoid w) => MonadTrans (RWST r w s) where
 146         lift m = RWST $ \_ s -> do
 147                 a <- m
 148                 return (a, s, mempty)
 149
 150 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
 151         liftIO = lift . liftIO
 152
 153
 154 evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
 155 evalRWST m r s = do
 156     (a, _, w) <- runRWST m r s
 157     return (a, w)
 158
 159 execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
 160 execRWST m r s = do
 161     (_, s', w) <- runRWST m r s
 162     return (s', w)
 163
 164 mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
 165 mapRWST f m = RWST $ \r s -> f (runRWST m r s)
 166
 167 withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
 168 withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)