import Data.Functor
import Data.Maybe
import Data.List
+import Data.Tuple
import Control.Applicative
import Control.Monad
import Control.Monad.State
import ast
-:: Eval a :== StateT EvalState (Either [String]) a
-:: EvalState :== [([Char], Value)]
+:: Eval a :== StateT [([Char], Value)] (Either [String]) a
-int :: Expression -> Either [String] Value
-int e = evalStateT (eval e) preamble
-
-preamble =
- [(['_if'], Func \i->pure (Func \t->pure (Func \e->eval i >>= \(Bool b)->if b (eval t) (eval e))))
- ,(['_eq'], binop \(Int i) (Int j)->Bool (i==j))
- ,(['_sub'], binop \(Int i) (Int j)->Int (i-j))
- ,(['_add'], binop \(Int i) (Int j)->Int (i+j))
- ,(['_mul'], binop \(Int i) (Int j)->Int (i*j))
- ,(['_div'], binop \(Int i) (Int j)->Int (i/j))
+int :: !Expression -> Either [String] Value
+int e = evalStateT (eval e)
+ [(['_if'], Builtin \i->pure (Lit (Builtin \t->pure (Lit (Builtin \e->
+ eval i >>= \(Bool b)->pure (if b t e))))))
+ ,(['_eq'], binop \(Int i) (Int j)->Bool (i == j))
+ ,(['_sub'], binop \(Int i) (Int j)->Int (i - j))
+ ,(['_add'], binop \(Int i) (Int j)->Int (i + j))
+ ,(['_mul'], binop \(Int i) (Int j)->Int (i * j))
+ ,(['_div'], binop \(Int i) (Int j)->Int (i / j))
]
where
- binop op = Func \l->pure (Func \r->op <$> eval l <*> eval r)
-
-sub :: [Char] Expression Expression -> Expression
-sub ident subst (Let v b rest) = Let v (sub ident subst b) (if (v == ident) rest (sub ident subst rest))
-sub ident subst (Var v)
- | ident == v = subst
-sub ident subst (App e1 e2) = App (sub ident subst e1) (sub ident subst e2)
-sub ident subst (Lambda v b)
- | ident <> v = Lambda v (sub ident b subst)
-sub _ _ x = x
+ binop :: (Value Value -> Value) -> Value
+ binop op = Builtin \l->pure (Lit (Builtin \r->(o) Lit o op <$> eval l <*> eval r))
eval :: Expression -> Eval Value
-eval (Let ident body rest) = eval body >>= \v->modify (\vs->[(ident, v):vs]) >>| eval rest
+eval (Let ns rest) = sequence [eval v >>= \v->modify (\vs->[(n, v):vs])\\(n, v)<-ns] >>| eval rest
eval (Lit v) = pure v
eval (Var v) = gets (lookup v) >>= maybe (liftT (Left [toString v +++ " not found"])) pure
-eval (App e1 e2) = eval e1 >>= \(Func v)->v e2
-eval (Lambda a b) = pure (Func \arg->eval (sub a arg b))
+eval (Lambda a b) = pure (Lambda` a b)
+eval (App e1 e2) = eval e1 >>= \v->case v of
+ (Lambda` v b) = eval (sub v e2 b)
+ (Builtin f) = f e2 >>= eval
+where
+ sub :: [Char] Expression Expression -> Expression
+ sub i subs (Let ns rest)
+ | not (isMember i (map fst ns)) = Let (fmap (sub i subs) <$> ns) (sub i subs rest)
+ sub i subs (Var v)
+ | i == v = subs
+ sub i subs (App e1 e2) = App (sub i subs e1) (sub i subs e2)
+ sub i subs (Lambda v b)
+ | i <> v = Lambda v (sub i subs b)
+ sub _ _ x = x