xilocaml / Interpreter.hs

module Interpreter where
import Control.Monad.State
import Data.List(findIndex)
import AbsXilocaml
import ErrM
import RunEnvironment
import PrettyShow
import Common
import Position


-- Interprets program and returns result of computation.
interpret :: Program -> Result
interpret p = evalStateT (transProgram p) startREnv


returnValue :: Value -> EnvRun Value
returnValue = lift . Ok

runtimeError :: String -> Exp -> EnvRun Value
runtimeError s x = lift $ Bad $ "Runtime error: " ++ s ++ " in " ++ (prettyShow $ position x) ++ " in "  ++ (prettyShow x) ++ "."


transProgram :: Program -> EnvRun Value
transProgram (Prog _ exp _) = transExp exp


transExp :: Exp -> EnvRun Value
transExp x = case x of
	ELetIn decls exp -> do
		s0 <- get
		transDecls decls
		v <- transExp exp
		put s0
		return v

	ELetRecIn decls exp -> do
		s0 <- get
		-- Here we add basic environment
		transDecls decls
		-- Here we loop environment for all functional variables
		loopEnvironment $ map localDeclIdent $ filter isFunDecl decls
		v <- transExp exp
		put s0
		return v

	ELambda args exp -> transFun args exp

	EIfThenElse expCond expTrue expFalse -> do
		c <- transExp expCond
		if bval c then
			transExp expTrue
		else
			transExp expFalse

	EOr expL expR -> do
		lv <- transExp expL
		if not $ bval lv then
			transExp expR
		else
			returnValue lv

	EAnd expL expR -> do
		lv <- transExp expL
		if bval lv then
			transExp expR
		else
			returnValue lv

	ECmp expL op expR -> do
		l <- transExp expL
		r <- transExp expR
		case l of
			VFun _ _ _ -> runtimeError "Comparison of functional values" x
			_ -> returnValue $ VBool $ comparator op l r

	EPrepend expElem expList -> do
		elemValue <- transExp expElem
		listValue <- transExp expList
		returnValue $ VList $ elemValue:(lelems listValue)

	EInfixWeak expL op expR -> do
		l <- transExp expL
		r <- transExp expR
		returnValue $ case op of
			OAdd -> VInt $ ival l + ival r
			OSub -> VInt $ ival l - ival r
			OAddFlt -> VFloat $ fval l + fval r
			OSubFlt -> VFloat $ fval l - fval r

	EInfixStrong expL op expR -> do
		l <- transExp expL
		r <- transExp expR
		case op of
			OMul -> returnValue $ VInt $ ival l * ival r
			ODiv ->
				if ival r == 0 then
					runtimeError "Division by zero" x
				else
					returnValue $ VInt $ ival l `div` ival r
			OMulFlt -> returnValue $ VFloat $ fval l * fval r
			ODivFlt -> returnValue $ VFloat $ fval l / fval r
			OMod ->
				if ival r == 0 then
					runtimeError "Division by zero" x
				else
					returnValue $ VInt $ ival l `mod` ival r

	EUnary op exp -> do
		v <- transExp exp
		case op of
			ONeg -> case v of
				VInt i -> returnValue $ VInt (-i)
				VFloat f -> returnValue $ VFloat (-f)
				_ -> error "Internal error: semantic error passed through semantics checker."
			OPos -> returnValue v
			ONegFlt -> returnValue $ VFloat $ -fval v
			OPosFlt -> returnValue v

	ENot exp -> do
		v <- transExp exp
		returnValue $ VBool $ not $ bval v

	EHead exp -> do
		v <- transExp exp
		case lelems v of
			[] -> runtimeError "Taking head of empty list" x
			_ -> returnValue $ head $ lelems v

	ETail exp -> do
		v <- transExp exp
		case lelems v of
			[] -> runtimeError "Taking tail of empty list" x
			_ -> returnValue $ VList $ tail $ lelems v

	EAppl exp arg -> do
		expVal <- transExp exp
		argVal <- transExp arg
		apply expVal argVal

	EInt str -> returnValue $ VInt $ transOInteger str

	EFloat str -> returnValue $ VFloat $ transOFloat str

	EBool str -> returnValue $ VBool $ transOBool str

	EList elems -> do
		let content (ListElement x) = x
		values <- transExps $ map content elems
		returnValue $ VList values

	EVar (OIdent (_, ident)) -> lookupEnv ident

	EExplType exp _ -> transExp exp


isFunDecl :: LocDecl -> Bool
isFunDecl decl = case decl of
	LocalVarDecl _ _ -> False
	LocalVarDeclExplType _ _ _ -> False
	_ -> True


transExps :: [Exp] -> EnvRun [Value]
transExps [] = do
	return []

transExps (exp:exps) = do
	v <- transExp exp
	vs <- transExps exps
	return $ v:vs


transOInteger :: OInteger -> Integer
transOInteger (OInteger (_, str)) = (read str)::Integer


transOBool :: OBool -> Bool
transOBool (OBool (_, str)) = case str of
	"true" -> True
	"false" -> False
	_ -> error "Internal error: string should be equal to true or false."


transOFloat :: OFloat -> Double
transOFloat (OFloat (_, str)) = let
	exponentDelimiter = findIndex (\x -> x == 'e' || x == 'E') str
	(fractionStr, exponentStr) = case exponentDelimiter of
		Nothing -> (str, "")
		Just delim -> (\(x,y) -> (x, tail y)) $ splitAt delim str
	fraction =
		if head fractionStr == '.' then
			(read $ '0':fractionStr)::Double
		else if head (reverse fractionStr) == '.' then
			(read $ fractionStr ++ "0")::Double
		else
			(read fractionStr)::Double
	exponent =
		if exponentStr == "" then
			0.0
		else if head exponentStr == '+' then
			(read $ tail exponentStr)::Double
		else
			(read $ exponentStr)::Double
	in fraction * (10 ** exponent)


transFun :: [Argument] -> Exp -> EnvRun Value
transFun args exp = do
	env <- get
	let argIdents = map argIdent args
	returnValue $ VFun env argIdents exp


argIdent :: Argument -> Ident
argIdent (FunArg (OIdent (_, ident))) = ident
argIdent (FunArgExplType (OIdent (_, ident)) _) = ident


apply :: Value -> Value -> EnvRun Value
apply (VFun fenv (farg:fargs) fexp) arg = do
	s0 <- get
	put fenv
	assignEnv farg arg
	v <- if fargs == [] then
			transExp fexp
		else do
			env <- get
			returnValue $ VFun env fargs fexp
	put s0
	returnValue v

apply _ _ = error "Internal error: wrong usage of apply function."


transDecls :: [LocDecl] -> EnvRun ()
transDecls [] = return ()

transDecls (decl:decls) = do
	v <- case decl of
		LocalVarDecl _ exp -> transExp exp
		LocalVarDeclExplType _ _ exp -> transExp exp
		LocalFunDecl _ args exp -> transFun args exp
		LocalFunDeclExplType _ args _ exp -> transFun args exp
	transDecls decls
	assignEnv (localDeclIdent decl) v
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.