Skip to content

Instantly share code, notes, and snippets.

@naoto-ogawa

naoto-ogawa/monadtransfomer_step_by_step.hs

Created January 9, 2017 05:03
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save naoto-ogawa/97fe0e1236f31aac9bbfd4a6c73a91b7 to your computer and use it in GitHub Desktop.
Save naoto-ogawa/97fe0e1236f31aac9bbfd4a6c73a91b7 to your computer and use it in GitHub Desktop.
Download ZIP
Monad Transformer step by step
Raw
monadtransfomer_step_by_step.hs
--
-- Monad Transformer Step by Step
--
-- https://page.mi.fu-berlin.de/scravy/realworldhaskell/materialien/monad-transformers-step-by-step.pdf
--
module Transformers where
import Control.Monad.Identity
import Control.Monad.Error -- deprecated Use Control.Monad.Except instead
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Maybe
import qualified Data.Map as Map
type Name = String
data Exp = Lit Integer
| Var Name
| Plus Exp Exp
| Abs Name Exp
| App Exp Exp
deriving (Show)
data Value = IntVal Integer
| FunVal Env Name Exp
deriving (Show)
type Env = Map.Map Name Value
-- 12 + ( (\x -> x) (4 + 2) )
exampleExp = Lit 12 `Plus` (App (Abs "x" (Var "x")) (Lit 4 `Plus` Lit 2))
-- > :t exampleExp
-- exampleExp :: Exp
-- x + y
exampleExp01 = (Var "x") `Plus` (Var "y")
-- 10 + App (1 2)
exampleExp02 = (Lit 10) `Plus` (App (Lit 2) (Lit 4))
exampleExp03 = (Abs "x" (Lit 1)) `Plus` (Abs "y" (Lit 2))
-- { x : 10, y : 13}
env01 = Map.fromList [("x", IntVal 10), ("y", IntVal 13)]
env02 = Map.fromList [("x", FunVal env01 "x" (Lit 10))]
--
-- vanilla
--
eval0 :: Env -> Exp -> Value
eval0 env (Lit i) = IntVal i
eval0 env (Var n) = fromJust (Map.lookup n env)
eval0 env (Plus e1 e2) = let IntVal i1 = eval0 env e1
IntVal i2 = eval0 env e2
in IntVal (i1 + i2)
eval0 env (Abs n e ) = FunVal env n e
eval0 env (App e1 e2 ) = let v1 = eval0 env e1
v2 = eval0 env e2
in case v1 of
FunVal env' n e3 -> eval0 (Map.insert n v2 env') e3
--
-- > eval0 Map.empty exampleExp
-- IntVal 18
-- > eval0 Map.empty exampleExp01
-- IntVal *** Exception: Maybe.fromJust: Nothing
-- > eval0 env01 exampleExp01
-- IntVal 23
-- >
--
--
-- Identity
--
-- let --> do, = --> <-
-- return
--
type Eval1 a = Identity a
runEval1 :: Eval1 a -> a
runEval1 ev = runIdentity ev
-- eval1 :: Env -> Exp -> Eval1 Value
eval1 :: Monad m => Env -> Exp -> m Value
eval1 env (Lit i) = return $ IntVal i
eval1 env (Var n) = maybe (fail ("undefined variable " ++ n)) return $ Map.lookup n env
eval1 env (Plus e1 e2) = do IntVal i1 <- eval1 env e1
IntVal i2 <- eval1 env e2
return $ IntVal (i1 + i2)
eval1 env (Abs n e) = return $ FunVal env n e
eval1 env (App e1 e2) = do val1 <- eval1 env e1
val2 <- eval1 env e2
case val1 of
FunVal env' n body -> eval1 (Map.insert n val2 env') body
-- > runEval1 (eval1 Map.empty exampleExp)
-- IntVal 18
-- > runEval1 (eval1 Map.empty exampleExp01)
-- *** Exception: undefined variable x
-- > runEval1 (eval1 env01 exampleExp01)
-- IntVal 23
--
-- Error
--
-- +----------------+
-- | |
-- Error Identity |
-- | |
-- +----------------+
--
--
type Eval2 a = ErrorT String Identity a
runEval2 :: Eval2 a -> Either String a
runEval2 ev = runIdentity (runErrorT ev)
eval2a :: Env -> Exp -> Eval2 Value
eval2a env (Lit i) = return $ IntVal i
eval2a env (Var n) = maybe (fail ("undefined variable " ++ n)) return $ Map.lookup n env
eval2a env (Plus e1 e2) = do IntVal i1 <- eval2a env e1
IntVal i2 <- eval2a env e2
return $ IntVal (i1 + i2)
eval2a env (Abs n e) = return $ FunVal env n e
eval2a env (App e1 e2) = do val1 <- eval2a env e1
val2 <- eval2a env e2
case val1 of
FunVal env' n body -> eval2a (Map.insert n val2 env') body
-- > runEval2 (eval2a Map.empty exampleExp)
-- Right (IntVal 18)
-- > runEval2 (eval2a env01 exampleExp01)
-- Right (IntVal 23)
-- > runEval2 (eval2a Map.empty exampleExp01)
-- Left "undefined variable x"
eval2b :: Env -> Exp -> Eval2 Value
eval2b env (Lit i) = return $ IntVal i
eval2b env (Var n) = maybe (fail ("undefined variable " ++ n)) return $ Map.lookup n env
eval2b env (Plus e1 e2) = do e1' <- eval2b env e1
e2' <- eval2b env e2
case (e1', e2') of
(IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
_ -> throwError "Type Error -- not IntVal"
eval2b env (Abs n e) = return $ FunVal env n e
eval2b env (App e1 e2) = do val1 <- eval2b env e1
val2 <- eval2b env e2
case val1 of
FunVal env' n body -> eval2b (Map.insert n val2 env') body
_ -> throwError "type Error -- not FunVal"
-- > runEval2 (eval2b env02 exampleExp03)
-- Left "Type Error -- not IntVal"
-- > runEval2 (eval2b Map.empty exampleExp02)
-- Left "type Error -- not FunVal"
-- > runEval2 (eval2b Map.empty (Var "x"))
-- Left "undefined variable x"
eval2 :: Env -> Exp -> Eval2 Value
eval2 env (Lit i) = return $ IntVal i
eval2 env (Var n) = case Map.lookup n env of
Nothing -> throwError ("unbound variable" ++ n)
Just val -> return val
eval2 env (Plus e1 e2) = do e1' <- eval2 env e1
e2' <- eval2 env e2
case (e1', e2') of
(IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
_ -> throwError "Type Error in addition"
eval2 env (Abs n e) = return $ FunVal env n e
eval2 env (App e1 e2) = do val1 <- eval2 env e1
val2 <- eval2 env e2
case val1 of
FunVal env' n body -> eval2 (Map.insert n val2 env') body
_ -> throwError "type Error in application"
--
-- Environment
--
--
--
--
type Eval3 a = ReaderT Env (ErrorT String Identity) a
runEval3 :: Env -> Eval3 a -> Either String a
runEval3 env ev = runIdentity (runErrorT (runReaderT ev env) )
eval3 :: Exp -> Eval3 Value
eval3 (Lit i) = return $ IntVal i
eval3 (Var n) = do env <- ask
case Map.lookup n env of
Nothing -> throwError ("unbound variable" ++ n)
Just val -> return val
eval3 (Plus e1 e2) = do e1' <- eval3 e1
e2' <- eval3 e2
case (e1', e2') of
(IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
_ -> throwError "type error in addition"
eval3 (Abs n e) = do env <- ask
return $ FunVal env n e
eval3 (App e1 e2) = do val1 <- eval3 e1
val3 <- eval3 e2
case val1 of
FunVal env' n body -> local (const (Map.insert n val3 env')) (eval3 body)
_ -> throwError "type error in application"
-- > runEval3 Map.empty (eval3 exampleExp)
-- Right (IntVal 18)
-- > runEval3 env01 (eval3 exampleExp01)
-- Right (IntVal 23)
-- > runEval3 env01 (eval3 exampleExp02)
-- Left "type error in application"
--
--
-- State Monad
--
-- StateT Integer Identity
-- ^ ^
-- | |
-- state wrapped monad
--
type Eval4 a = ReaderT Env (ErrorT String (StateT Integer Identity)) a
runEval4 :: Env -> Integer -> Eval4 a -> (Either String a, Integer)
runEval4 env st ev = runIdentity (runStateT (runErrorT (runReaderT ev env) ) st )
-- | ^^^^^ |
-- | state |
-- +--------------------------------------------------+
tick :: (Num s, MonadState s m) => m ()
tick = get >>= (\x -> put (x + 1))
eval4 :: Exp -> Eval4 Value
eval4 (Lit i) = do tick
return $ IntVal i
eval4 (Var n) = do tick
env <- ask
case Map.lookup n env of
Nothing -> throwError ("unbound variable" ++ n)
Just val -> return val
eval4 (Plus e1 e2) = do tick
e1' <- eval4 e1
e2' <- eval4 e2
case (e1', e2') of
(IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
_ -> throwError "type error in addition"
eval4 (Abs n e) = do tick
env <- ask
return $ FunVal env n e
eval4 (App e1 e2) = do tick
val1 <- eval4 e1
val2 <- eval4 e2
case val1 of
FunVal env' n body -> local (const (Map.insert n val2 env')) (eval4 body)
_ -> throwError "type error in application"
-- > :t runEval4
-- runEval4 :: Env -> Integer -> Eval4 a -> (Either String a, Integer)
-- > :t eval4
-- eval4 :: Exp -> Eval4 Value
-- > runEval4 Map.empty 0 (eval4 exampleExp)
-- (Right (IntVal 18),8)
-- > runEval4 env01 0 (eval4 exampleExp02)
-- (Left "type error in application",5)
-- >
-- type Eval4 a = ReaderT Env (ErrorT String (StateT Integer Identity)) a
type Eval4' a = ReaderT Env (StateT Integer (ErrorT String Identity)) a
-- runEval4 :: Env -> Integer -> Eval4 a -> (Either String a, Integer)
runEval4' :: Env -> Integer -> Eval4' a -> (Either String (a, Integer))
runEval4' env st ev = runIdentity (runErrorT (runStateT (runReaderT ev env) st ) )
-- | ^^^^^ |
-- | state |
-- +-------------------------------------+
eval4' :: Exp -> Eval4' Value
eval4' (Lit i) = do tick
return $ IntVal i
eval4' (Var n) = do tick
env <- ask
case Map.lookup n env of
Nothing -> throwError ("unbound variable" ++ n)
Just val -> return val
eval4' (Plus e1 e2) = do tick
e1' <- eval4' e1
e2' <- eval4' e2
case (e1', e2') of
(IntVal i1, IntVal i2) -> return $ IntVal (i1 + i2)
_ -> throwError "type error in addition"
eval4' (Abs n e) = do tick
env <- ask
return $ FunVal env n e
eval4' (App e1 e2) = do tick
val1 <- eval4' e1
val2 <- eval4' e2
case val1 of
FunVal env' n body -> local (const (Map.insert n val2 env')) (eval4' body)
_ -> throwError "type error in application"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment