RWST.icl

   1 implementation module RWST
   2
   3 from StdFunc import o
   4 import StdTuple
   5
   6 from Data.Func import $
   7 import Data.Functor.Identity
   8 import Data.Functor
   9 import Data.Monoid
  10 import Control.Monad
  11 import Control.Monad.Trans
  12 import Control.Applicative
  13
  14 // The RWS monad
  15 :: RWS r w s a :== RWST r w s Identity a
  16
  17 rws :: (r -> s -> (a, s, w)) -> RWS r w s a
  18 rws f = RWST \r s->Identity $ f r s
  19
  20 runRWS :: (RWS r w s a) r s -> (a, s, w)
  21 runRWS m r s = runIdentity $ runRWST m r s
  22
  23 evalRWS :: (RWS r w s a) r s -> (a, w)
  24 evalRWS m r s = let (a, _, w) = runRWS m r s in (a, w)
  25
  26 execRWS :: (RWS r w s a) r s -> (s, w)
  27 execRWS m r s = let (_, s`, w) = runRWS m r s in (s`, w)
  28
  29 mapRWS :: ((a, s, w) -> (b, s, w`)) (RWS r w s a) -> RWS r w` s b
  30 mapRWS f m = mapRWST (Identity o f o runIdentity) m
  31
  32 withRWS :: (r` s -> (r, s)) (RWS r w s a) -> RWS r` w s a
  33 withRWS f m = withRWST f m
  34
  35 // The RWST monad transformer
  36 :: RWST r w s m a = RWST (r s -> m (a, s, w))
  37
  38 instance Functor (RWST r w s m) | Monad m & Monoid w where
  39         fmap f m = liftM f m
  40
  41 instance Applicative (RWST r w s m) | Monad m & Monoid w where
  42     pure a = RWST \_ s->pure (a, s, mempty)
  43         (<*>) mf mx = ap mf mx
  44
  45 instance Monad (RWST r w s m) | Monad m & Monoid w where
  46         bind m k = RWST \r s->runRWST m r s
  47                 >>= \(a, s`, w)->runRWST (k a) r s`
  48                 >>= \(b, s``,w`)->pure (b, s``, mappend w w`)
  49
  50 instance MonadTrans (RWST r w s) | Monoid w where
  51         liftT m = RWST \_ s->m >>= \a->pure (a, s, mempty)
  52
  53 runRWST :: (RWST r w s m a) r s -> m (a, s, w)
  54 runRWST (RWST f) r s = f r s
  55
  56 evalRWST :: (RWST r w s m a) r s -> m (a, w) | Monad m
  57 evalRWST m r s = runRWST m r s >>= \(a, _, w)->pure (a, w)
  58
  59 execRWST :: (RWST r w s m a) r s -> m (s, w) | Monad m
  60 execRWST m r s = runRWST m r s >>= \(_, s`, w)->pure (s, w)
  61
  62 mapRWST :: ((m (a, s, w)) -> n (b, s, w`)) (RWST r w s m a) -> RWST r w` s n b
  63 mapRWST f m = RWST \r s->f $ runRWST m r s
  64
  65 withRWST :: (r` -> s -> (r, s)) (RWST r w s m a) -> RWST r` w s m a
  66 withRWST f m = RWST \r s->uncurry (runRWST m) $ f r s
  67
  68 // Reader operations
  69 ask :: RWST r w s m r | Monoid w & Monad m
  70 ask = RWST \r s->pure (r, s, mempty)
  71
  72 local :: (r -> r) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m
  73 local f m = RWST \r s->runRWST m (f r) s
  74
  75 asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m
  76 asks f = ask >>= \r->pure $ f r
  77
  78 // Writer operations
  79 tell :: w -> RWST r w s m () | Monoid w & Monad m
  80 tell w = RWST \_ s->pure ((), s,w)
  81
  82 listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m
  83 listen m = RWST \r s->runRWST m r s >>= \(a, s`, w)->pure ((a, w), s`, w)
  84
  85 pass :: (RWST r w s m (a, w -> w)) -> RWST r w s m a | Monoid w & Monad m
  86 pass m = RWST \r s->runRWST m r s >>= \((a, f), s`, w)->pure (a, s`, f w)
  87
  88 listens :: (w -> b) (RWST r w s m a) -> RWST r w s m (a, b)| Monoid w & Monad m
  89 listens f m = listen m >>= \(a, w)->pure (a, f w)
  90
  91 censor :: (w -> w) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m
  92 censor f m = pass $ m >>= \a->pure (a, f)
  93
  94 // State operation
  95 get :: RWST r w s m s | Monoid w & Monad m
  96 get = RWST \_ s->pure (s, s, mempty)
  97
  98 put :: s -> RWST r w s m () | Monoid w & Monad m
  99 put s = RWST \_ _->pure ((), s, mempty)
 100
 101 modify :: (s -> s) -> RWST r w s m () | Monoid w & Monad m
 102 modify f = get >>= \s->put $ f s
 103
 104 gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m
 105 gets f = get >>= \s->pure $ f s
 106
 107 // Lifting other operations
 108 liftCallCC :: ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a | Monoid w
 109 liftCallCC callCC f = RWST \r s->callCC
 110         \c->runRWST (f $ \a->RWST \_ _->c (a, s, mempty)) r s
 111
 112 liftCallCC` :: ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a | Monoid w
 113 liftCallCC` callCC f = RWST \r s->callCC
 114         \c->runRWST (f $ \a->RWST \_ s`->c (a, s`, mempty)) r s
 115
 116 liftCatch :: ((m (a,s,w)) (e -> m (a,s,w)) -> m (a,s,w)) (RWST l w s m a) (e -> RWST l w s m a) -> RWST l w s m a
 117 liftCatch catchError m h = RWST \r s->catchError
 118         (runRWST m r s) (\e->runRWST (h e) r s)