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