implementation module int

import StdEnv

import Data.Either
import Data.Functor
import Data.Maybe
import Data.List
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

import ast

int :: Expression -> Either [String] Value
int e = evalStateT (eval e >>= printer) preamble

err :: String -> Eval a
err e = liftT (Left [e])

:: Eval a :== StateT EvalState (Either [String]) a
:: EvalState :== [([Char], Value)]
preamble =
	[(['if'], Func 3 [] (Builtin ['if']))
	,(['eq'], Func 2 [] (Builtin ['eq']))
	,(['mul'], Func 2 [] (Builtin ['mul']))
	,(['div'], Func 2 [] (Builtin ['div']))
	,(['add'], Func 2 [] (Builtin ['add']))
	,(['sub'], Func 2 [] (Builtin ['sub']))
	]

sub :: [Char] Expression Expression -> Expression
sub ident subst (Let v a b rest)
	= Let v a (if (isMember ident a) b (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

printer :: Value -> Eval Value
printer (Func 0 args body) = eval (body args) >>= printer
printer a = pure a

eval :: Expression -> Eval Value
eval (Let ident as body rest)
	=   modify (\vs->[(ident, Func (length as) [] \e->zipSt sub as e body):vs])
	>>| eval rest
eval (Lit v) = pure v
eval (Var v) = gets (lookup v)
	>>= maybe (err ("Variable " +++ toString v +++ " not found")) pure
eval (App e1 e2) = eval e1 >>= \v->case v of
	(Func 0 a b) = err ("Saturated function: : " +++ toString e1)
	(Func n as b) = pure (Func (n-1) (as ++ [e2]) b)
	_ = err ("Cannot apply " +++ toString e2 +++ " to " +++ toString e1)
eval (Lambda a b) = pure (Func 1 [] (\[arg]->sub a arg b))
eval (Builtin i as) = case (i, as) of
	(['if'], [p,t,e]) = eval p >>= printer >>= \v->case v of
		Bool v = eval (if v t e)
//		_ = err ("first argument of if must be a bool but is " +++ toString v)
	(['add'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
		(Int a, Int b) = pure (Int (a + b))
//		_ = err "add only defined for integers"
	(['sub'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
		(Int a, Int b) = pure (Int (a - b))
//		_ = err "sub only defined for integers"
	(['mul'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
		(Int a, Int b) = pure (Int (a * b))
//		_ = err "mul only defined for integers"
	(['div'], [l,r]) = eval l >>= \l->eval r >>= \r->case (l,r) of
		(Int a, Int b) = pure (Int (a / b))
//		_ = err "div only defined for integers"
	(['eq'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
		(Int a, Int b) = pure (Bool (a == b))
//		_ = err "eq only defined for integers"