module Control.Monad.Trans.RWSIO (
    -- * Synopsis
    -- | An implementation of the reader/writer/state monad transformer
    -- using an 'IORef'.

    -- * Documentation
    RWSIOT(..), Tuple(..), rwsT, runRWSIOT, tell, ask, get, put,
    ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.IORef
import Data.Monoid

{-----------------------------------------------------------------------------
    Type and class instances
------------------------------------------------------------------------------}
data Tuple r w s = Tuple !r !(IORef w) !(IORef s)

newtype RWSIOT r w s m a = R { RWSIOT r w s m a -> Tuple r w s -> m a
run :: Tuple r w s -> m a }

instance Functor m => Functor (RWSIOT r w s m) where fmap :: (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
fmap = (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
forall (m :: * -> *) a b r w s.
Functor m =>
(a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
fmapR

instance Applicative m => Applicative (RWSIOT r w s m) where
    pure :: a -> RWSIOT r w s m a
pure  = a -> RWSIOT r w s m a
forall (m :: * -> *) a r w s.
Applicative m =>
a -> RWSIOT r w s m a
pureR
    <*> :: RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
(<*>) = RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
forall (m :: * -> *) r w s a b.
Applicative m =>
RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
apR

instance Monad m => Monad (RWSIOT r w s m) where
    return :: a -> RWSIOT r w s m a
return = a -> RWSIOT r w s m a
forall (m :: * -> *) a r w s. Monad m => a -> RWSIOT r w s m a
returnR
    >>= :: RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b
(>>=)  = RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b
forall (m :: * -> *) r w s a b.
Monad m =>
RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b
bindR

instance MonadFix m => MonadFix (RWSIOT r w s m) where mfix :: (a -> RWSIOT r w s m a) -> RWSIOT r w s m a
mfix = (a -> RWSIOT r w s m a) -> RWSIOT r w s m a
forall (m :: * -> *) a r w s.
MonadFix m =>
(a -> RWSIOT r w s m a) -> RWSIOT r w s m a
mfixR
instance MonadIO m => MonadIO (RWSIOT r w s m)   where liftIO :: IO a -> RWSIOT r w s m a
liftIO = IO a -> RWSIOT r w s m a
forall (m :: * -> *) a r w s. MonadIO m => IO a -> RWSIOT r w s m a
liftIOR
instance MonadTrans (RWSIOT r w s)               where lift :: m a -> RWSIOT r w s m a
lift = m a -> RWSIOT r w s m a
forall (m :: * -> *) a r w s. m a -> RWSIOT r w s m a
liftR

{-----------------------------------------------------------------------------
    Functions
------------------------------------------------------------------------------}
liftIOR :: MonadIO m => IO a -> RWSIOT r w s m a
liftIOR :: IO a -> RWSIOT r w s m a
liftIOR IO a
m = (Tuple r w s -> m a) -> RWSIOT r w s m a
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m a) -> RWSIOT r w s m a)
-> (Tuple r w s -> m a) -> RWSIOT r w s m a
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
_ -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m

liftR :: m a -> RWSIOT r w s m a
liftR :: m a -> RWSIOT r w s m a
liftR   m a
m = (Tuple r w s -> m a) -> RWSIOT r w s m a
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m a) -> RWSIOT r w s m a)
-> (Tuple r w s -> m a) -> RWSIOT r w s m a
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
_ -> m a
m

fmapR :: Functor m => (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
fmapR :: (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
fmapR a -> b
f RWSIOT r w s m a
m = (Tuple r w s -> m b) -> RWSIOT r w s m b
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m b) -> RWSIOT r w s m b)
-> (Tuple r w s -> m b) -> RWSIOT r w s m b
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
x -> (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (RWSIOT r w s m a -> Tuple r w s -> m a
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run RWSIOT r w s m a
m Tuple r w s
x)

returnR :: Monad m => a -> RWSIOT r w s m a
returnR :: a -> RWSIOT r w s m a
returnR a
a = (Tuple r w s -> m a) -> RWSIOT r w s m a
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m a) -> RWSIOT r w s m a)
-> (Tuple r w s -> m a) -> RWSIOT r w s m a
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
_ -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

bindR :: Monad m => RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b
bindR :: RWSIOT r w s m a -> (a -> RWSIOT r w s m b) -> RWSIOT r w s m b
bindR RWSIOT r w s m a
m a -> RWSIOT r w s m b
k = (Tuple r w s -> m b) -> RWSIOT r w s m b
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m b) -> RWSIOT r w s m b)
-> (Tuple r w s -> m b) -> RWSIOT r w s m b
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
x -> RWSIOT r w s m a -> Tuple r w s -> m a
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run RWSIOT r w s m a
m Tuple r w s
x m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> RWSIOT r w s m b -> Tuple r w s -> m b
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run (a -> RWSIOT r w s m b
k a
a) Tuple r w s
x

mfixR :: MonadFix m => (a -> RWSIOT r w s m a) -> RWSIOT r w s m a
mfixR :: (a -> RWSIOT r w s m a) -> RWSIOT r w s m a
mfixR a -> RWSIOT r w s m a
f   = (Tuple r w s -> m a) -> RWSIOT r w s m a
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m a) -> RWSIOT r w s m a)
-> (Tuple r w s -> m a) -> RWSIOT r w s m a
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
x -> (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (\a
a -> RWSIOT r w s m a -> Tuple r w s -> m a
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run (a -> RWSIOT r w s m a
f a
a) Tuple r w s
x)

pureR :: Applicative m => a -> RWSIOT r w s m a
pureR :: a -> RWSIOT r w s m a
pureR a
a   = (Tuple r w s -> m a) -> RWSIOT r w s m a
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m a) -> RWSIOT r w s m a)
-> (Tuple r w s -> m a) -> RWSIOT r w s m a
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
_ -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

apR :: Applicative m => RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
apR :: RWSIOT r w s m (a -> b) -> RWSIOT r w s m a -> RWSIOT r w s m b
apR RWSIOT r w s m (a -> b)
f RWSIOT r w s m a
a   = (Tuple r w s -> m b) -> RWSIOT r w s m b
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m b) -> RWSIOT r w s m b)
-> (Tuple r w s -> m b) -> RWSIOT r w s m b
forall a b. (a -> b) -> a -> b
$ \Tuple r w s
x -> RWSIOT r w s m (a -> b) -> Tuple r w s -> m (a -> b)
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run RWSIOT r w s m (a -> b)
f Tuple r w s
x m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RWSIOT r w s m a -> Tuple r w s -> m a
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run RWSIOT r w s m a
a Tuple r w s
x

rwsT :: (MonadIO m, Monoid w) => (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a
rwsT :: (r -> s -> IO (a, s, w)) -> RWSIOT r w s m a
rwsT r -> s -> IO (a, s, w)
f = do
    r
r <- RWSIOT r w s m r
forall (m :: * -> *) r w s. Monad m => RWSIOT r w s m r
ask
    s
s <- RWSIOT r w s m s
forall (m :: * -> *) r w s. MonadIO m => RWSIOT r w s m s
get
    (a
a,s
s,w
w) <- IO (a, s, w) -> RWSIOT r w s m (a, s, w)
forall (m :: * -> *) a r w s. MonadIO m => IO a -> RWSIOT r w s m a
liftIOR (IO (a, s, w) -> RWSIOT r w s m (a, s, w))
-> IO (a, s, w) -> RWSIOT r w s m (a, s, w)
forall a b. (a -> b) -> a -> b
$ r -> s -> IO (a, s, w)
f r
r s
s
    s -> RWSIOT r w s m ()
forall (m :: * -> *) s r w. MonadIO m => s -> RWSIOT r w s m ()
put  s
s
    w -> RWSIOT r w s m ()
forall (m :: * -> *) w r s.
(MonadIO m, Monoid w) =>
w -> RWSIOT r w s m ()
tell w
w
    a -> RWSIOT r w s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

runRWSIOT :: (MonadIO m, Monoid w) => RWSIOT r w s m a -> (r -> s -> m (a,s,w))
runRWSIOT :: RWSIOT r w s m a -> r -> s -> m (a, s, w)
runRWSIOT RWSIOT r w s m a
m r
r s
s = do
    IORef w
w' <- IO (IORef w) -> m (IORef w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef w) -> m (IORef w)) -> IO (IORef w) -> m (IORef w)
forall a b. (a -> b) -> a -> b
$ w -> IO (IORef w)
forall a. a -> IO (IORef a)
newIORef w
forall a. Monoid a => a
mempty
    IORef s
s' <- IO (IORef s) -> m (IORef s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef s) -> m (IORef s)) -> IO (IORef s) -> m (IORef s)
forall a b. (a -> b) -> a -> b
$ s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
s
    a
a  <- RWSIOT r w s m a -> Tuple r w s -> m a
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
run RWSIOT r w s m a
m (r -> IORef w -> IORef s -> Tuple r w s
forall r w s. r -> IORef w -> IORef s -> Tuple r w s
Tuple r
r IORef w
w' IORef s
s')
    s
s  <- IO s -> m s
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO s -> m s) -> IO s -> m s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
s'
    w
w  <- IO w -> m w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO w -> m w) -> IO w -> m w
forall a b. (a -> b) -> a -> b
$ IORef w -> IO w
forall a. IORef a -> IO a
readIORef IORef w
w'
    (a, s, w) -> m (a, s, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,s
s,w
w)

tell :: (MonadIO m, Monoid w) => w -> RWSIOT r w s m ()
tell :: w -> RWSIOT r w s m ()
tell w
w = (Tuple r w s -> m ()) -> RWSIOT r w s m ()
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m ()) -> RWSIOT r w s m ())
-> (Tuple r w s -> m ()) -> RWSIOT r w s m ()
forall a b. (a -> b) -> a -> b
$ \(Tuple r
_ IORef w
w' IORef s
_) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef w -> (w -> w) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef w
w' (w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w)

ask :: Monad m => RWSIOT r w s m r
ask :: RWSIOT r w s m r
ask = (Tuple r w s -> m r) -> RWSIOT r w s m r
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m r) -> RWSIOT r w s m r)
-> (Tuple r w s -> m r) -> RWSIOT r w s m r
forall a b. (a -> b) -> a -> b
$ \(Tuple r
r IORef w
_ IORef s
_) -> r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r

get :: MonadIO m => RWSIOT r w s m s
get :: RWSIOT r w s m s
get = (Tuple r w s -> m s) -> RWSIOT r w s m s
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m s) -> RWSIOT r w s m s)
-> (Tuple r w s -> m s) -> RWSIOT r w s m s
forall a b. (a -> b) -> a -> b
$ \(Tuple r
_ IORef w
_ IORef s
s') -> IO s -> m s
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO s -> m s) -> IO s -> m s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
s'

put :: MonadIO m => s -> RWSIOT r w s m ()
put :: s -> RWSIOT r w s m ()
put s
s = (Tuple r w s -> m ()) -> RWSIOT r w s m ()
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
R ((Tuple r w s -> m ()) -> RWSIOT r w s m ())
-> (Tuple r w s -> m ()) -> RWSIOT r w s m ()
forall a b. (a -> b) -> a -> b
$ \(Tuple r
_ IORef w
_ IORef s
s') -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef s -> s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef s
s' s
s

test :: RWSIOT String String () IO ()
test :: RWSIOT String String () IO ()
test = do
    String
c <- RWSIOT String String () IO String
forall (m :: * -> *) r w s. Monad m => RWSIOT r w s m r
ask
    String -> RWSIOT String String () IO ()
forall (m :: * -> *) w r s.
(MonadIO m, Monoid w) =>
w -> RWSIOT r w s m ()
tell String
c