Eval.hs

{- LANGUAGE Arrows -}
{-# OPTIONS -F -pgmF arrowp-ext #-}
module Eval where

-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)

import           Control.Arrow
import           Data.Maybe    (fromJust)

type Id = String
data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))
data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp

eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a)
eval (Var s) = proc env ->
		returnA -< fromJust (lookup s env)
eval (Add e1 e2) = proc env -> do
		~(Num u) <- eval e1 -< env
		~(Num v) <- eval e2 -< env
		returnA -< Num (u + v)
eval (If e1 e2 e3) = proc env -> do
		~(Bl b) <- eval e1 -< env
		if b	then eval e2 -< env
			else eval e3 -< env
eval (Lam x e) = proc env ->
		returnA -< Fun (proc v -> eval e -< (x,v):env)
eval (App e1 e2) = proc env -> do
		~(Fun f) <- eval e1 -< env
		v <- eval e2 -<< env
		f -< v

-- some tests

i = Lam "x" (Var "x")
k = Lam "x" (Lam "y" (Var "x"))
double = Lam "x" (Add (Var "x") (Var "x"))

t = n
	where Num n = eval (If (Var "b")
			(App (App k (App double (Var "x"))) (Var "x"))
			(Add (Var "x") (Add (Var "x") (Var "x"))))
		[("b", Bl True), ("x", Num 5)]