module Monadic where -------------------- -- Arithmetic operators data Opr = Add | Mul deriving Show fopr f g Add = f; fopr f g Mul = g syn = fopr "+" "*" sem = fopr (+) (*) -------------------- -- Arithmetic terms with imperative variables data Expr a b c = Lit a | Use c | Set c (Expr a b c) | Bop b (Expr a b c) (Expr a b c) deriving Show infx (Lit k) = show k infx (Use x) = x infx (Set x e) = inpar "=" x (infx e) infx (Bop b l r) = inpar (syn b) (infx l) (infx r) inpar o l r = concat ["(",l," ",o," ",r,")"] -------------------- -- Evaluation in direct recursive style eval (Lit k) s = (k, s) eval (Use x) s = (s x, s) eval (Set x e) s = let (v,t) = eval e s in (v, update s x v) eval (Bop b l r) s = let (v,t) = eval r s (w,u) = eval l t in (sem b w v, u) try e = fst (eval e (const 0)) -------------------- -- Imperative (state) monad and state functions newtype Imp s a = Imp (s -> (a,s)) instance Monad (Imp s) where return v = Imp (\s -> (v,s)) Imp p >>= f = Imp (\s -> let (v,t) = p s Imp q = f v in q t) update f x v = \y -> if y==x then v else f y get x = Imp (\s -> (s x, s)) set x v = Imp (\s -> ((), update s x v)) -------------------- -- Evaluation in monadic style mval (Lit k) = do return k mval (Use x) = do v <- get x return v mval (Set x e) = do v <- mval e set x v return v mval (Bop b l r) = do v <- mval r w <- mval l return (sem b w v) try' e = let (Imp s) = mval e in fst (s (const 0)) -------------------- -- Test sample -- (x * (x = 2)) + ((5 * x) + ((x = 3) * 4)) test = Bop Add (Bop Mul (Use "x") (Set "x" (Lit 2))) (Bop Add (Bop Mul (Lit 5) (Use "x")) (Bop Mul (Set "x" (Lit 3)) (Lit 4))) -- Right to left: -- (x * (x = 2)) + ((5 * x) + ((x = 3) * 4)) { _ = 0 } -- (x * (x = 2)) + ((5 * x) + ( 3 * 4)) { x = 3 } -- (x * (x = 2)) + ((5 * x) + ( 12 )) { x = 3 } -- (x * (x = 2)) + ((5 * 3) + 12 ) { x = 3 } -- (x * (x = 2)) + ( 15 + 12 ) { x = 3 } -- (x * (x = 2)) + 27 { x = 3 } -- (x * 2 ) + 27 { x = 2 } <-- NB! -- (2 * 2 ) + 27 { x = 2 } -- ( 4 ) + 27 { x = 2 } -- 31 { x = 2 } -- Left to right: -- (x * (x = 2)) + ((5 * x) + ((x = 3) * 4)) { _ = 0 } -- (0 * (x = 2)) + ((5 * x) + ((x = 3) * 4)) { _ = 0 } -- (0 * 2) + ((5 * x) + ((x = 3) * 4)) { x = 2 } <-- NB! -- 0 + ((5 * x) + ((x = 3) * 4)) { x = 2 } -- 0 + ((5 * 2) + ((x = 3) * 4)) { x = 2 } -- 0 + (10 + ((x = 3) * 4)) { x = 2 } -- 0 + (10 + (3 * 4)) { x = 3 } <-- NB! -- 0 + (10 + 12) { x = 3 } -- 0 + 22 { x = 3 } -- 22 { x = 3 }