--------------------
-- Layered expression/program semantics
-- LLC class, Spring 2006 * Fritz Ruehr
--------------------

module Prog where
default (Int)


--------------------
-- Expressions (no imperative behavior)

data Expr a b c = Lit a | Bop b (Expr a b c) (Expr a b c) | 
                  Occ c | Let c (Expr a b c) (Expr a b c)

data Var = Var Char deriving Eq

type Exp = Expr Val Opr Var


-- operators and their semantics (uniform domain of Ints)

data Opr = Add | Mul | Sub | And | Or | Equ | Leq

sem Add = (+)
sem Mul = (*)
sem Sub = (-)
sem And = (*)
sem Or  = max
sem Equ = chi (==)
sem Leq = chi (<=)

chi p x y = if p x y then 1 else 0


--------------------
-- Statements will have imperative behavior, but not values

data Stmt = Set Var Exp | If Exp Stmt Stmt | While Exp Stmt | Block [Stmt]


-- Values and updateable environments

type Val = Int
type Env = Var -> Val

upd f x v y = if y==x then v else f y


--------------------
-- Meanings for Exprs (eval) and Stmts (perf, for 'perform')

eval :: Exp -> Env -> Val
eval (Lit a)     e = a
eval (Occ v)     e = e v
eval (Bop b l r) e = sem b (eval l e) (eval r e)
eval (Let v d b) e = eval b (upd e v (eval d e))


perf :: Stmt -> Env -> Env
perf (Set v r)   e = upd e v (eval r e)
perf (If b x y)  e = if eval b e /= 0 then perf x e else perf y e
perf (Block xs)  e = foldl (flip perf) e xs
perf (While b x) e = until ((==0) . eval b) (perf x) e


--------------------
-- A test case illustrating an embedded, shadowing "Let"
-- (TRY, E.G., 'watch "in" test')

test = Block [ i =: one,
               n =: one,
               While (Occ i <=: ten)
                   ( Block [ i =: (Occ i +: one) ,
                             n =: (Occ n *: tthw) ] ) ]

tthw = Let i one (Occ i +: Occ i)    -- two "the hard way"

(=:) = Set
[i, n]                 = map Var "in"
[zero, one ,two, ten]  = map Lit [0,1,2,10]
[(<=:),(+:),(*:),(-:)] = map Bop [Leq,Add,Mul,Sub]


-- Print utilities

prtenv xs e = "{ " ++ concatMap prt xs ++ "... }"
              where prt x = x : " = " ++ show (e (Var x)) ++ "; "

watch vs p = putStrLn ("\n\t" ++ prtenv vs (perf p undefined))