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/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  non-portable (multi-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         evalRWS,
  24         execRWS,
  25         mapRWS,
  26         withRWS,
  27         RWST(..),
  28         evalRWST,
  29         execRWST,
  30         mapRWST,
  31         withRWST,
  32         module Control.Monad.Reader,
  33         module Control.Monad.Writer,
  34         module Control.Monad.State,
  35   ) where
  36
  37 import Prelude
  38
  39 import Control.Monad
  40 import Control.Monad.Fix
  41 import Control.Monad.Trans
  42 import Control.Monad.Reader
  43 import Control.Monad.Writer
  44 import Control.Monad.State
  45 import Data.Monoid
  46
  47 newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
  48
  49 instance Functor (RWS r w s) where
  50         fmap f m = RWS $ \r s -> let
  51                 (a, s', w) = runRWS m r s
  52                 in (f a, s', w)
  53
  54 instance (Monoid w) => Monad (RWS r w s) where
  55         return a = RWS $ \_ s -> (a, s, mempty)
  56         m >>= k  = RWS $ \r s -> let
  57                 (a, s',  w)  = runRWS m r s
  58                 (b, s'', w') = runRWS (k a) r s'
  59                 in (b, s'', w `mappend` w')
  60
  61 instance (Monoid w) => MonadFix (RWS r w s) where
  62         mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
  63
  64 instance (Monoid w) => MonadReader r (RWS r w s) where
  65         ask       = RWS $ \r s -> (r, s, mempty)
  66         local f m = RWS $ \r s -> runRWS m (f r) s
  67
  68 instance (Monoid w) => MonadWriter w (RWS r w s) where
  69         tell   w = RWS $ \_ s -> ((), s, w)
  70         listen m = RWS $ \r s -> let
  71                 (a, s', w) = runRWS m r s
  72                 in ((a, w), s', w)
  73         pass   m = RWS $ \r s -> let
  74                 ((a, f), s', w) = runRWS m r s
  75                 in (a, s', f w)
  76
  77 instance (Monoid w) => MonadState s (RWS r w s) where
  78         get   = RWS $ \_ s -> (s, s, mempty)
  79         put s = RWS $ \_ _ -> ((), s, mempty)
  80
  81
  82 evalRWS :: RWS r w s a -> r -> s -> (a, w)
  83 evalRWS m r s = let
  84     (a, _, w) = runRWS m r s
  85     in (a, w)
  86
  87 execRWS :: RWS r w s a -> r -> s -> (s, w)
  88 execRWS m r s = let
  89     (_, s', w) = runRWS m r s
  90     in (s', w)
  91
  92 mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
  93 mapRWS f m = RWS $ \r s -> f (runRWS m r s)
  94
  95 withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
  96 withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
  97
  98
  99 newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
 100
 101 instance (Monad m) => Functor (RWST r w s m) where
 102         fmap f m = RWST $ \r s -> do
 103                 (a, s', w) <- runRWST m r s
 104                 return (f a, s', w)
 105
 106 instance (Monoid w, Monad m) => Monad (RWST r w s m) where
 107         return a = RWST $ \_ s -> return (a, s, mempty)
 108         m >>= k  = RWST $ \r s -> do
 109                 (a, s', w)  <- runRWST m r s
 110                 (b, s'',w') <- runRWST (k a) r s'
 111                 return (b, s'', w `mappend` w')
 112         fail msg = RWST $ \_ _ -> fail msg
 113
 114 instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
 115         mzero       = RWST $ \_ _ -> mzero
 116         m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
 117
 118 instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
 119         mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
 120
 121 instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
 122         ask       = RWST $ \r s -> return (r, s, mempty)
 123         local f m = RWST $ \r s -> runRWST m (f r) s
 124
 125 instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
 126         tell   w = RWST $ \_ s -> return ((),s,w)
 127         listen m = RWST $ \r s -> do
 128                 (a, s', w) <- runRWST m r s
 129                 return ((a, w), s', w)
 130         pass   m = RWST $ \r s -> do
 131                 ((a, f), s', w) <- runRWST m r s
 132                 return (a, s', f w)
 133
 134 instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
 135         get   = RWST $ \_ s -> return (s, s, mempty)
 136         put s = RWST $ \_ _ -> return ((), s, mempty)
 137
 138 instance (Monoid w) => MonadTrans (RWST r w s) where
 139         lift m = RWST $ \_ s -> do
 140                 a <- m
 141                 return (a, s, mempty)
 142
 143 instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
 144         liftIO = lift . liftIO
 145
 146
 147 evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
 148 evalRWST m r s = do
 149     (a, _, w) <- runRWST m r s
 150     return (a, w)
 151
 152 execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
 153 execRWST m r s = do
 154     (_, s', w) <- runRWST m r s
 155     return (s', w)
 156
 157 mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
 158 mapRWST f m = RWST $ \r s -> f (runRWST m r s)
 159
 160 withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
 161 withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)