module Language.Qux.Interpreter (
Execution, Evaluation,
runExecution,
Context, Locals,
context,
exec, execStmt,
evalExpr
) where
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Either
import Data.List ((\\))
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.Maybe (fromJust, isJust)
import Language.Qux.Syntax
type Execution = EitherT Value Evaluation
type Evaluation = StateT Locals (Reader Context)
runExecution :: (a -> Value) -> Execution a -> Evaluation Value
runExecution f exec = either id f <$> runEitherT exec
data Context = Context {
functions :: Map Id ([Id], [Stmt])
}
type Locals = Map Id Value
context :: Program -> Context
context (Program decls) = Context { functions = Map.fromList $ map (\d -> (name d, (parameterNames d, stmts d))) decls }
once :: Monad m => MonadState s m => (s -> s) -> m a -> m a
once f m = get >>= \save -> modify f >> m <* put save
exec :: Program -> Id -> [Value] -> Value
exec program entry arguments = runReader (evalStateT (evalApplicationExpr entry arguments) Map.empty) (context program)
execBlock :: [Stmt] -> Execution ()
execBlock = mapM_ execStmt
execStmt :: Stmt -> Execution ()
execStmt (IfStmt condition trueStmts falseStmts) = do
result <- lift $ evalExpr condition
execBlock $ case runBoolValue result of
True -> trueStmts
False -> falseStmts
execStmt (ReturnStmt expr) = lift (evalExpr expr) >>= left
execStmt s@(WhileStmt condition stmts) = do
result <- lift $ evalExpr condition
when (runBoolValue result) $ execBlock stmts >> execStmt s
evalExpr :: Expr -> Evaluation Value
evalExpr (ApplicationExpr name arguments) = mapM evalExpr arguments >>= evalApplicationExpr name
evalExpr (BinaryExpr op lhs rhs) = do
lhs' <- evalExpr lhs
rhs' <- evalExpr rhs
evalBinaryExpr op lhs' rhs'
evalExpr (ListExpr exprs) = ListValue <$> mapM evalExpr exprs
evalExpr (UnaryExpr op expr) = evalExpr expr >>= evalUnaryExpr op
evalExpr (ValueExpr value) = return value
evalApplicationExpr :: Id -> [Value] -> Evaluation Value
evalApplicationExpr name arguments = do
maybeValue <- gets $ Map.lookup name
if isJust maybeValue then
return $ fromJust maybeValue
else do
(parameters, stmts) <- asks $ (! name) . functions
once (Map.union $ Map.fromList (zip parameters arguments)) (runExecution undefined (execBlock stmts))
evalBinaryExpr :: BinaryOp -> Value -> Value -> Evaluation Value
evalBinaryExpr Acc (ListValue elements) (IntValue rhs) = return $ elements !! (fromInteger rhs)
evalBinaryExpr Mul (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs * rhs)
evalBinaryExpr Div (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs `div` rhs)
evalBinaryExpr Mod (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs `mod` rhs)
evalBinaryExpr Add (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs + rhs)
evalBinaryExpr Add (ListValue lhs) (ListValue rhs) = return $ ListValue (lhs ++ rhs)
evalBinaryExpr Sub (IntValue lhs) (IntValue rhs) = return $ IntValue (lhs rhs)
evalBinaryExpr Sub (ListValue lhs) (ListValue rhs) = return $ ListValue (lhs \\ rhs)
evalBinaryExpr Lt (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs < rhs)
evalBinaryExpr Lte (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs <= rhs)
evalBinaryExpr Gt (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs > rhs)
evalBinaryExpr Gte (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs >= rhs)
evalBinaryExpr Eq (BoolValue lhs) (BoolValue rhs) = return $ BoolValue (lhs == rhs)
evalBinaryExpr Eq (IntValue lhs) (IntValue rhs) = return $ BoolValue (lhs == rhs)
evalBinaryExpr Eq (ListValue lhs) (ListValue rhs) = return $ BoolValue (lhs == rhs)
evalBinaryExpr Eq NilValue NilValue = return $ BoolValue True
evalBinaryExpr Eq _ _ = return $ BoolValue False
evalBinaryExpr Neq lhs rhs = evalBinaryExpr Eq lhs rhs >>= return . BoolValue . not . runBoolValue
evalUnaryExpr :: UnaryOp -> Value -> Evaluation Value
evalUnaryExpr Len (ListValue elements) = return $ IntValue (toInteger $ length elements)
evalUnaryExpr Neg (IntValue value) = return $ IntValue (value)
runBoolValue :: Value -> Bool
runBoolValue (BoolValue value) = value