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