--------------------------------------------- -- 001
-- Funcional language with a nice abstraction -- 002
--------------------------------------------- -- 003
-- 004
-- 005
-- variables are just names -- 006
type Var = String -- 007
-- 008
-- values are integers and functions -- 009
data Value = ValInt Integer -- 010
| ValFunc (Value -> Cmpt Value) -- 011
-- 012
-- final results are strings (to be printed) -- 013
type Result = String -- 014
-- 015
-- only zero is false -- 016
isTrue :: Value -> Bool -- 017
isTrue (ValInt 0) = False -- 018
isTrue _ = True -- 019
-- 020
-- continuations -- 021
type K a = a -> Result -- 022
-- 023
-- 024
-- a computation gets a continuation and gives a result -- 025
type Cmpt a = K a -> Result -- 026
-- 027
-- transforms a value into a computation -- 028
unit :: a -> Cmpt a -- 029
unit x = \k -> k x -- 030
-- 031
-- executes an unary operation on computations -- 032
bind :: Cmpt a -> (a -> Cmpt b) -> Cmpt b -- 033
bind ca op = \k -> ca (\a -> op a k) -- 034
-- 035
-- computation error -- 036
cerror :: String -> Cmpt a -- 037
cerror s k = s -- 038
-- 039
-- 040
-- an Environment maps variables to Values through continuations -- 041
type Env = Var -> Cmpt Value -- 042
-- 043
-- 044
-- An empty Environment -- 045
emptyEnv :: Env -- 046
emptyEnv v = cerror ("undefined variable " ++ v) -- 047
-- 048
-- 049
-- bind a new value in an environment -- 050
bindenv :: Var -> Value -> Env -> Env -- 051
bindenv var val env = \v -> if (var == v) then (unit val) else (env v) -- 052
-- 053
-- executes a binary operation on computations -- 054
op2 :: (a -> b -> Cmpt c) -> Cmpt a -> Cmpt b -> Cmpt c -- 055
op2 op ca cb = bind ca (\a -> bind cb (op a)) -- 056
-- 057
-- executes a binary integer operation on computations -- 058
arith :: (Integer -> Integer -> Integer) -> -- 059
(Cmpt Value -> Cmpt Value -> Cmpt Value) -- 060
arith op = op2 op_aux -- 061
where op_aux (ValInt i1) (ValInt i2) = unit (ValInt (op i1 i2)) -- 062
op_aux _ _ = cerror "binary operation over non-int value" -- 063
-- 064
-- 065
-------------------------------------------------------------------- -- 066
-- Abstract Syntax Tree for Expressions -- 067
data Exp = ExpK Integer -- constants -- 068
| ExpVar Var -- variables -- 069
| ExpAdd Exp Exp -- e1 + e2 -- 070
| ExpSub Exp Exp -- e1 - e2 -- 071
| ExpMul Exp Exp -- e1 * e2 -- 072
| ExpDiv Exp Exp -- e1 / e2 -- 073
| ExpIf Exp Exp Exp -- if e1 then e2 else e3 -- 074
| ExpApp Exp Exp -- e1 e2 -- 075
| ExpLambda Var Exp -- \x -> e -- 076
| ExpLetrec Var Var Exp Exp -- letrec x=(\x'->e') in e -- 077
-- 078
-- creates a closure in given environment -- 079
closure :: Var -> Exp -> Env -> Value -- 080
closure v e env = ValFunc (\x -> evalExp e (bindenv v x env)) -- 081
-- 082
-- 083
-- Evaluates an expression in a given environment -- 084
evalExp :: Exp -> Env -> Cmpt Value -- 085
-- 086
evalExp (ExpK i) env = unit (ValInt i) -- 087
evalExp (ExpVar v) env = env v -- 088
evalExp (ExpAdd e1 e2) env = arith (+) (evalExp e1 env) (evalExp e2 env) -- 089
evalExp (ExpSub e1 e2) env = arith (-) (evalExp e1 env) (evalExp e2 env) -- 090
evalExp (ExpMul e1 e2) env = arith (*) (evalExp e1 env) (evalExp e2 env) -- 091
evalExp (ExpDiv e1 e2) env = arith div (evalExp e1 env) (evalExp e2 env) -- 092
-- 093
evalExp (ExpIf e1 e2 e3) env = -- 094
bind (evalExp e1 env) (\b -> if isTrue b then evalExp e2 env -- 095
else evalExp e3 env) -- 096
-- 097
evalExp (ExpApp e1 e2) env = op2 app (evalExp e1 env) (evalExp e2 env) -- 098
where app (ValFunc f) vp = f vp -- 099
app _ _ = cerror "attempt to call a non-function value" -- 100
-- 101
evalExp (ExpLambda v e) env = unit (closure v e env) -- 102
-- 103
evalExp (ExpLetrec v v' e' e) env = evalExp e env' -- 104
where env' = bindenv v (closure v' e' env') env -- 105
-- 106
-- 107
---------------------------------------------------------------------------- 108
-- 109
-- 110
------------------------------------------------------------------- -- 111
-- some examples -- 112
-- 113
-- (34 + 52) or 0 -- 114
exp1 = ExpIf (ExpAdd (ExpK 34) (ExpK 52)) (ExpK 43) (ExpK 4) -- 115
-- 116
f1 = ExpLambda "x" (ExpApp (ExpVar "x") (ExpVar "x")) -- 117
f2 = ExpApp f1 f1 -- 118
-- 119
f3 = ExpApp (ExpLambda "x" (ExpK 3)) f2 -- 120
-- 121
-- 122
fat4 = ExpLetrec "f" -- 123
"x" -- 124
(ExpIf (ExpVar "x") -- 125
(ExpMul (ExpVar "x") -- 126
(ExpApp (ExpVar "f") -- 127
(ExpSub (ExpVar "x") (ExpK 1)))) -- 128
(ExpK 1)) -- 129
(ExpApp (ExpVar "f") (ExpK 5)) -- 130
-- 131
-- 132
-- 133
-- code to show the final value of an expression -- 134
main :: IO () -- 135
main = print (evalExp fat4 emptyEnv k) -- 136
where k x = case x of -- 137
ValInt i -> show i -- 138
ValFunc _ -> "function" -- 139
-- 140