New monads/UnboxedRWS
< New monads
Jump to navigation
Jump to search
Revision as of 10:25, 12 January 2007 by ChrisKuklewicz (talk | contribs)
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
This is from the haskell-cafe mailing list.
Date: Thu, 11 Jan 2007 19:29:49 -0800 From: John Meacham <john@repetae.net> To: haskell-cafe@haskell.org incidentally, I made a very strict and unboxed version of the RWS monad, since it is a darn useful one in jhc. right now, it only implements the things I needed, but it might be useful to include somewhere common and expanded on http://repetae.net/dw/darcsweb.cgi?r=3Djhc;a=3Dheadblob;f=3D/Util/RWS.hs John
{-# OPTIONS_GHC -fglasgow-exts -fbang-patterns #-}
-- modified from Control.Monad.RWS by John Meacham to be strict
module Util.RWS (
RWS,
runRWS,
-- evalRWS,
-- execRWS,
-- mapRWS,
-- withRWS,
-- RWST(..),
-- evalRWST,
-- execRWST,
-- mapRWST,
-- withRWST,
module Control.Monad.Reader,
module Control.Monad.Writer,
module Control.Monad.State,
) where
import Prelude
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Data.Monoid
newtype RWS r w s a = RWS { runRWS' :: r -> s -> (# a, s, w #) }
runRWS :: RWS r w s a -> r -> s -> (a,s,w)
runRWS x r s = case runRWS' x r s of
(# a, b, c #) -> (a,b,c)
instance Functor (RWS r w s) where
fmap f m = RWS $ \r s -> case runRWS' m r s of
(# a, s', w #) -> (# f a, s', w #)
instance (Monoid w) => Monad (RWS r w s) where
return a = RWS $ \_ s -> (# a, s, mempty #)
m >>= k = RWS $ \r s -> case runRWS' m r s of
(# a, s', w #) -> case runRWS' (k a) r s' of
(# b, s'', w' #) -> let !w'' = w `mappend` w'
in (# b, s'', w'' #)
--instance (Monoid w) => MonadFix (RWS r w s) where
-- mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
instance (Monoid w) => MonadReader r (RWS r w s) where
ask = RWS $ \r s -> (# r, s, mempty #)
local f m = RWS $ \r s -> let !r' = f r in runRWS' m r' s
instance (Monoid w) => MonadWriter w (RWS r w s) where
tell w = RWS $ \_ s -> (# (), s, w #)
listen m = RWS $ \r s -> case runRWS' m r s of
(# a, s', w #) -> (# (a, w), s', w #)
pass m = RWS $ \r s -> case runRWS' m r s of
(# (a, f), s', w #) -> let !w' = f w in (# a, s', w' #)
instance (Monoid w) => MonadState s (RWS r w s) where
get = RWS $ \_ s -> (# s, s, mempty #)
put !s = RWS $ \_ _ -> (# (), s, mempty #)
{-
evalRWS :: RWS r w s a -> r -> s -> (a, w)
evalRWS m r s = let
(a, _, w) = runRWS m r s
in (a, w)
execRWS :: RWS r w s a -> r -> s -> (s, w)
execRWS m r s = let
(_, s', w) = runRWS m r s
in (s', w)
mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
mapRWS f m = RWS $ \r s -> f (runRWS m r s)
withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
instance (Monad m) => Functor (RWST r w s m) where
fmap f m = RWST $ \r s -> do
(a, s', w) <- runRWST m r s
return (f a, s', w)
instance (Monoid w, Monad m) => Monad (RWST r w s m) where
return a = RWST $ \_ s -> return (a, s, mempty)
m >>= k = RWST $ \r s -> do
(a, s', w) <- runRWST m r s
(b, s'',w') <- runRWST (k a) r s'
return (b, s'', w `mappend` w')
fail msg = RWST $ \_ _ -> fail msg
instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
mzero = RWST $ \_ _ -> mzero
m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
ask = RWST $ \r s -> return (r, s, mempty)
local f m = RWST $ \r s -> runRWST m (f r) s
instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
tell w = RWST $ \_ s -> return ((),s,w)
listen m = RWST $ \r s -> do
(a, s', w) <- runRWST m r s
return ((a, w), s', w)
pass m = RWST $ \r s -> do
((a, f), s', w) <- runRWST m r s
return (a, s', f w)
instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
get = RWST $ \_ s -> return (s, s, mempty)
put s = RWST $ \_ _ -> return ((), s, mempty)
instance (Monoid w) => MonadTrans (RWST r w s) where
lift m = RWST $ \_ s -> do
a <- m
return (a, s, mempty)
instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
liftIO = lift . liftIO
evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
evalRWST m r s = do
(a, _, w) <- runRWST m r s
return (a, w)
execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
execRWST m r s = do
(_, s', w) <- runRWST m r s
return (s', w)
mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST f m = RWST $ \r s -> f (runRWST m r s)
withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)
-}