DeepControl.MonadTrans

This module enables you to program in Monad-Transformer style for more deeper level than the usual Control.Monad.Trans module expresses. You would realize exactly what more deeper level means by reading the example codes, which are attached on the page bottom. Note: all the MonadTransx instances for Level-4 and Level-5 haven't been written yet.

MonadIO

class Monad m => MonadIO m where

Monads in which IO computations may be embedded. Any monad built by applying a sequence of monad transformers to the IO monad will be an instance of this class.

Instances should satisfy the following laws, which state that liftIO is a transformer of monads:

• liftIO . return = return

• liftIO (m >>= f) = liftIO m >>= (liftIO . f)

Methods

liftIO :: IO a -> m a

Lift a computation from the IO monad.

Instances

MonadIO IO

MonadIO m => MonadIO (ListT m)

MonadIO m => MonadIO (MaybeT m)

MonadIO m => MonadIO (IdentityT m)

MonadIO m => MonadIO (ListT m)

MonadIO m => MonadIO (MaybeT m)

MonadIO m => MonadIO (ContT r m)

MonadIO m => MonadIO (ReaderT r m)

MonadIO m => MonadIO (StateT s m)

MonadIO m => MonadIO (StateT s m)

MonadIO m => MonadIO (ExceptT e m)

(Error e, MonadIO m) => MonadIO (ErrorT e m)

(Monoid w, MonadIO m) => MonadIO (WriterT w m)

(Monoid w, MonadIO m) => MonadIO (WriterT w m)

MonadIO m => MonadIO (ExceptT e m)

(MonadIO m, Monad m) => MonadIO (ReaderT r m)

(MonadIO m, Monad m) => MonadIO (StateT s m)

(Monoid w, MonadIO m, Monad m) => MonadIO (WriterT w m)

(MonadIO m1, Monad m1, Monad2 m2) => MonadIO (ReaderT2 r m1 m2)

(MonadIO m1, Monad m1, Monad2 m2) => MonadIO (StateT2 s m1 m2)

(Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (WriterT2 w m1 m2)

(Monoid w, MonadIO m) => MonadIO (RWST r w s m)

(Monoid w, MonadIO m) => MonadIO (RWST r w s m)

(Monoid w, MonadIO m, Monad m) => MonadIO (RWST r w s m)

(MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (ReaderT3 r m1 m2 m3)

(MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (StateT3 s m1 m2 m3)

(Monoid w, MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (WriterT3 w m1 m2 m3)

(Monoid w, MonadIO m1, Monad m1, Monad2 m2) => MonadIO (RWST2 r w s m1 m2)

(Monoid w, MonadIO m1, Monad m1, Monad2 m2, Monad3 m3) => MonadIO (RWST3 r w s m1 m2 m3)

MonadTrans

class MonadTrans t where

Methods

trans :: Monad m => m a -> t m a

Alias for lift.

Instances

MonadTrans ListT

MonadTrans MaybeT

MonadTrans (ExceptT e)

MonadTrans (ReaderT r)

MonadTrans (StateT s)

Monoid w => MonadTrans (WriterT w)

Monoid w => MonadTrans (RWST r w s)

class MonadTrans2 t where

Methods

trans2 :: (Monad m1, Monad2 m2) => m1 (m2 a) -> t m1 m2 a

Instances

MonadTrans2 (ReaderT2 r)

MonadTrans2 (StateT2 s)

Monoid w => MonadTrans2 (WriterT2 w)

Monoid w => MonadTrans2 (RWST2 r w s)

class MonadTrans3 t where

Methods

trans3 :: (Monad m1, Monad2 m2, Monad3 m3) => m1 (m2 (m3 a)) -> t m1 m2 m3 a

Instances

MonadTrans3 (ReaderT3 r)

MonadTrans3 (StateT3 s)

Monoid w => MonadTrans3 (WriterT3 w)

Monoid w => MonadTrans3 (RWST3 r w s)

class MonadTrans4 t where

Methods

trans4 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4) => m1 (m2 (m3 (m4 a))) -> t m1 m2 m3 m4 a

class MonadTrans5 t where

Methods

trans5 :: (Monad m1, Monad2 m2, Monad3 m3, Monad4 m4, Monad5 m5) => m1 (m2 (m3 (m4 (m5 a)))) -> t m1 m2 m3 m4 m5 a

Level-1 example

Here is a monad transformer example how to implement a tiny interpreter with RWST-ExceptT-IO monad, a level-1 monad-transformation.

Please turn on three pragmas GeneralizedNewtypeDeriving, FlexibleInstances and MultiParamTypeClasses on this example.

import DeepControl.Applicative
import DeepControl.Monad
import DeepControl.MonadTrans
import DeepControl.Monad.Except
import DeepControl.Monad.RWS

import qualified Data.Map as M

-- ----------------------------------------------
-- Data-types

type Name = String          -- variable names

-- Expression
data Exp = Lit Int          -- Literal
         | Var Name         -- Variable
         | Plus Exp Exp     -- (+)
         | Lam Name Exp     -- λ
         | App Exp Exp      -- Application
         deriving (Show)

-- Value
data Value = IntVal Int          -- Int Value 
           | FunVal Env Name Exp -- Functional Value
           deriving (Show)

-- Environment
type Env = M.Map Name Value    -- mapping from names to values

-- ----------------------------------------------
-- Monad-Transform

type EvalError = String
instance Error EvalError where
    strMsg x = x
 
newtype Eval a = Eval (RWST Env [String] Int 
                      (ExceptT EvalError
                          IO) a)
  deriving (Functor, Applicative, Monad, MonadIO)

unEval :: Eval a -> (RWST Env [String] Int 
                    (ExceptT EvalError
                        IO) a)
unEval (Eval a) = a

runEval :: Eval a 
           -> Env  -- Reader
           -> Int  -- States
           -> IO (Either EvalError (a, Int, [String])) 
runEval (Eval x) env state = x >- \x -> runRWST x env state
                               >- runExceptT

instance MonadError EvalError Eval where
    throwError = Eval . trans . throwError
    catchError x h = 
        let x' = unEval x
        in Eval $ (liftCatch catchError x') (\e -> unEval (h e))
instance MonadReader Env Eval where
    ask     = Eval $ ask
    local x = Eval . (local x) . unEval
instance MonadWriter [String] Eval where
    writer   = Eval . writer
    listen m = Eval $ (listen (unEval m)) 
    pass m   = Eval $ (pass (unEval m)) 
instance MonadState Int Eval where
    get   = Eval $ get
    put   = Eval . put
    state = Eval . state

-- ----------------------------------------------
-- Interpreter

tick :: (Num s, MonadState s m) => m ()
tick = do 
    st <- get
    put (st + 1)

eval :: Exp -> Eval Value
eval (Lit i)   = do 
    tick
    liftIO $ print i
    return $ IntVal i
eval (Var n)   = do 
    tick
    tell [n]
    env <- ask
    case M.lookup n env of
        Nothing  -> throwError $ "unbound variable: " ++ n
        Just val -> return val
eval (Plus e1 e2) = do 
    tick
    e1' <- eval e1
    e2' <- eval e2
    case (e1', e2') of
        (IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
        _                      -> throwError "type error in addition"
eval (Lam n e) = do 
    tick
    env <- ask
    return $ FunVal env n e
eval (App e1 e2) = do 
    tick
    val1 <- eval e1
    val2 <- eval e2
    case val1 of
        FunVal env' n body -> local (const (M.insert n val2 env')) $ eval body
        _                  -> throwError "type error in application"

-- ----------------------------------------------
-- Examples

-- 12 + ((\x -> x) (4 + 2))
exp1 :: Exp
exp1 = Lit 12 `Plus` ((Lam "x" (Var "x")) `App` (Lit 4 `Plus` Lit 2))

-- (\x -> (\y -> x + y)) a b
exp2 :: Exp
exp2 = (Lam "x" (Lam "y" ((Var "x") `Plus` (Var "y")))) `App` (Var "a") `App` (Var "b")

-- An environment
env :: Env
env = M.fromList [ ("a", IntVal 1)
                 , ("b", IntVal 2)
                 , ("c", IntVal 3)  
                 , ("d", IntVal 4)
                 ] 

-- ----------------------------------------------
-- Tests
--
-- > runEval (eval exp1) env 0
-- 12
-- 4
-- 2
-- Right (IntVal 18,8,["x"])

-- > runEval (eval exp2) env 0
-- Right (IntVal 3,9,["a","b","x","y"])

-- > runEval (eval $ Var "x") env 0
-- Left "unbound variable: x"

Level-2 example

Here is a monad transformer example how to implement Polish Notation with StateT2-IO-Maybe monad, a level-2 monad-transformation.

import DeepControl.Applicative
import DeepControl.Commutative (cmap)
import DeepControl.Monad
import DeepControl.Monad.State
import DeepControl.MonadTrans

-----------------------------------------------
-- State

push :: a -> State [a] a
push x = do 
    xs <- get
    put (x:xs)
    return x

pop :: State [a] a
pop = do 
    xs <- get
    put (tail xs)
    return (head xs)

-- > runState (push 1 >> push 2 >> push 3) []
-- (3,[3,2,1])
-- > runState (push 1 >> push 2 >> push 3 >> pop >> pop) []
-- (2,[1])

poland :: String -> State [Double] Double
poland "+" = do 
    x <- pop
    y <- pop
    push (y + x)
poland "-" = do 
    x <- pop
    y <- pop
    push (y - x)
poland "*" = do 
    x <- pop
    y <- pop
    push (y * x)
poland "/" = do
    x <- pop
    y <- pop
    push (y / x)
poland x = push (read x :: Double)

poland_calc :: [String] -> Double
poland_calc xs = evalState (cmap poland xs >> pop) []

-- > poland_calc ["1","2","*"]
-- 2.0
-- > poland_calc ["1","2","-"]
-- -1.0
-- > poland_calc ["1","2","+","3","*"]
-- 9.0
-- > poland_calc ["1","2","+","3","*","3","/"]
-- 3.0
-- > poland_calc ["1","2","+","3","*","0","/"]
-- Infinity

-----------------------------------------------
-- StateT-Maybe

pushT :: a -> StateT [a] Maybe a
pushT x = do 
    xs <- get
    put (x:xs)
    return x

popT :: StateT [a] Maybe a
popT = do 
    xs <- get
    put (tail xs)
    return (head xs)

-- > runStateT (pushT 1 >> pushT 2 >> pushT 3) []
-- Just (3,[3,2,1])
-- > runStateT (pushT 1 >> pushT 2 >> pushT 3 >> popT >> popT) []
-- Just (2,[1])

polandT :: String -> StateT [Double] Maybe Double
polandT "+" = do 
    x <- popT
    y <- popT
    pushT (y + x)
polandT "-" = do 
    x <- popT
    y <- popT
    pushT (y - x)
polandT "*" = do 
    x <- popT
    y <- popT
    pushT (y * x)
polandT "/" = do
    x <- popT
    y <- popT
    trans $ guard (x /= 0)
    pushT (y / x)
polandT x = pushT (read x :: Double)

poland_calcT :: [String] -> Maybe Double
poland_calcT xs = evalStateT (cmap polandT xs >> popT) []

-- > poland_calcT ["1","2","*"]
-- Just 2.0
-- > poland_calcT ["1","2","-"]
-- Just (-1.0)
-- > poland_calcT ["1","2","+","3","*"]
-- Just 9.0
-- > poland_calcT ["1","2","+","3","*","3","/"]
-- Just 3.0
-- > poland_calcT ["1","2","+","3","*","0","/"]
-- Nothing

-----------------------------------------------
-- StateT2-IO-Maybe

pushT2 :: a -> StateT2 [a] IO Maybe a
pushT2 x = do 
    xs <- get
    put (x:xs)
    return x
popT2 :: StateT2 [a] IO Maybe a
popT2 = do 
    xs <- get
    put (tail xs)
    return (head xs)

polandT2 :: String -> StateT2 [Double] IO Maybe Double
polandT2 "+" = do 
    x <- popT2
    y <- popT2
    liftIO $ putStrLn (show y ++" + "++ show x ++" = "++ show (y + x))
    pushT2 (y + x)
polandT2 "-" = do 
    x <- popT2
    y <- popT2
    liftIO $ putStrLn (show y ++" - "++ show x ++" = "++ show (y - x))
    pushT2 (y - x)
polandT2 "*" = do
    x <- popT2
    y <- popT2
    liftIO $ putStrLn (show y ++" * "++ show x ++" = "++ show (y * x))
    pushT2 (y * x)
polandT2 "/" = do
    x <- popT2
    y <- popT2
    liftIO $ putStr (show y ++" / "++ show x ++" = ")
    trans2.(*:) $ guard (x /= 0)
    liftIO $ putStr (show (y / x) ++"\n")
    pushT2 (y / x)
polandT2 x = pushT2 (read x :: Double)

poland_calcT2 :: [String] -> IO (Maybe Double)
poland_calcT2 xs = evalStateT2 (cmap polandT2 xs >> popT2) []

-- > poland_calcT2 ["1","2","*"]
-- 1.0 * 2.0 = 2.0
-- Just 2.0
-- > poland_calcT2 ["1","2","+","3","*"]
-- 1.0 + 2.0 = 3.0
-- 3.0 * 3.0 = 9.0
-- Just 9.0
-- > poland_calcT2 ["1","2","+","3","*","3","/"]
-- 1.0 + 2.0 = 3.0
-- 3.0 * 3.0 = 9.0
-- 9.0 / 3.0 = 3.0
-- Just 3.0
-- > poland_calcT2 ["1","2","+","3","*","0","/"]
-- 1.0 + 2.0 = 3.0
-- 3.0 * 3.0 = 9.0
-- 9.0 / 0.0 = Nothing