repos / machines.hs.git

SEC.hs

 1module Abstract.SEC where
 2
 3-- https://www.brics.dk/RS/03/33/BRICS-RS-03-33.pdf
 4
 5data Term = Appl Term Term | Var String | Abst String Term | Lit Int
 6  deriving (Show)
 7
 8data Val = Num Int | Succ | Closure Term String Env
 9  deriving (Show)
10
11data Directive = DTerm Term | DApply
12
13type Stack = [Val]
14type Env = [(String, Val)]
15type Control = Stack -> Env -> Stack
16
17initEnv :: Env
18initEnv = [("succ", Succ)]
19
20eval :: Term -> Stack -> Env -> Control -> Stack
21eval (Lit n) s e c = c ((Num n):s) e
22eval (Var x) s e c = case lookup x e of
23  Just v -> c (v:s) e
24  Nothing -> error "var not in scope"
25eval (Abst x t) s e c = c ((Closure t x e):s) e
26eval (Appl t0 t1) s e c =
27  eval t1 s e $ \s' e' ->
28    eval t0 s' e' $ \s'' e'' -> 
29      apply s'' e'' c
30
31apply :: Stack -> Env -> Control -> Stack
32apply (Succ : (Num n):s) e c = c ((Num $ n + 1):s) e
33apply ((Closure t x e'):v':s) e c =
34  let [v] = eval t [] ((x, v'):e') (\s' _ -> s')
35  in c (v:s) e
36
37evaluate :: Term -> Val
38evaluate t =
39  let [v] = eval t [] initEnv (\s _ -> s)
40  in v
41
42-- (\ 0 0) (\ 0)
43t1 :: Term
44t1 = Appl (Abst "x" (Appl (Var "x") (Var "x"))) (Abst "x" (Appl (Var "succ") (Lit 1)))
45
46ex1 :: Val
47ex1 = evaluate t1
48
49--((λ 0) (λ 0)) (λ 0)
50t2 :: Term
51t2 = Appl (Appl (Abst "x" $ Var "x") (Abst "x" $ Var "x")) (Abst "x" $ Var "x")
52
53ex2 :: Val
54ex2 = evaluate t2