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