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