123 lines
4.1 KiB
Haskell
123 lines
4.1 KiB
Haskell
module BC.Eval (eval) where
|
|
|
|
import qualified Data.HashMap as M
|
|
|
|
import BC.State
|
|
import BC.Types
|
|
|
|
truthy :: Value -> Bool
|
|
truthy (BNum num) = num /= 0
|
|
truthy (BBool x) = x
|
|
truthy _ = False
|
|
|
|
|
|
eval :: State -> [Value] -> (Value, State)
|
|
eval state [x@(BNum _)] = (x, state)
|
|
eval state [(BDef (BSym sym) expr)] =
|
|
let (val, newstate) = eval state expr
|
|
in (val, M.insert sym val newstate)
|
|
eval state [x@(BFun sym _ _)] = (BBool True, M.insert sym x state)
|
|
eval state [x@(BBool _)] = (x, state)
|
|
eval state [x@(BErr _)] = (x, state)
|
|
eval state [x@(BWhile cond body)] =
|
|
let (evald, whilestate) = eval state cond
|
|
in
|
|
if truthy evald
|
|
then let
|
|
(bodyval, newstate) = eval whilestate body
|
|
(val, retstate) = eval newstate [x]
|
|
in if truthy val then (val, retstate) else (bodyval, retstate)
|
|
else (BBool False, whilestate)
|
|
eval state [(BIf cond body alt)] =
|
|
let (evald, ifstate) = eval state cond
|
|
in
|
|
if truthy evald
|
|
then eval ifstate body
|
|
else case alt of
|
|
Just vals -> eval ifstate vals
|
|
Nothing -> (BBool False, ifstate)
|
|
eval state [(BSym x)] =
|
|
case M.lookup x state of
|
|
Just val -> (val, state)
|
|
Nothing -> (BErr (x ++ " is undefined"), state)
|
|
eval state [(BCall (BSym name) args)] =
|
|
case M.lookup name state of
|
|
Just val@(BFun _ _ _) -> funCall state val args
|
|
Nothing -> (BErr ("function " ++ name ++ " is undefined"), state)
|
|
_ -> (BErr (name ++ " is not a function"), state)
|
|
eval state [] = (BSym "", state)
|
|
eval state l = (treeEval state l [] [], state)
|
|
|
|
|
|
treeEval :: State -> [Value] -> [Value] -> [Value] -> Value
|
|
treeEval _ [] [] (num:_) = num
|
|
treeEval state [] ops nums = handleOp state [] ops nums
|
|
treeEval state (x@(BIf _ _ _):xy) ops nums =
|
|
let (val, newstate) = eval state [x]
|
|
in treeEval newstate (val:xy) ops nums
|
|
treeEval state (x@(BNum _):xy) ops nums = treeEval state xy ops (x:nums)
|
|
treeEval state ((BBool x):xy) ops nums =
|
|
treeEval state xy ops ((BNum $ BInt $ if x then 1 else 0):nums)
|
|
treeEval state expr@(x@(BSym sym):xy) ops@(op:_) nums =
|
|
case M.lookup sym state of
|
|
Just val -> treeEval state xy ops (val:nums)
|
|
Nothing ->
|
|
if precedence x > precedence op
|
|
then treeEval state xy (x:ops) nums
|
|
else handleOp state expr ops nums
|
|
treeEval state (x@(BSym sym):xy) [] nums =
|
|
case M.lookup sym state of
|
|
Just val -> treeEval state xy [] (val:nums)
|
|
Nothing -> treeEval state xy [x] nums
|
|
|
|
|
|
handleOp :: State -> [Value] -> [Value] -> [Value] -> Value
|
|
handleOp state expr (op:ops) ((BNum op2):((BNum op1):nums)) =
|
|
treeEval state expr ops (((findOp op) op1 op2):nums)
|
|
handleOp _ expr ((BSym op):ops) _ = BErr ("Not enough arguments to operation " ++ op)
|
|
|
|
|
|
findOp x = case binOp x of
|
|
Just op -> \a -> \b -> (BNum $ op a b)
|
|
Nothing ->
|
|
case logicalOp x of
|
|
Just lop -> \a -> \b -> (BBool $ lop a b)
|
|
Nothing -> \a -> \b -> (BNum $ BInt 0)
|
|
|
|
|
|
logicalOp :: Value -> Maybe (Number -> Number -> Bool)
|
|
logicalOp (BSym ">") = Just (>)
|
|
logicalOp (BSym "<") = Just (<)
|
|
logicalOp (BSym ">=") = Just (>=)
|
|
logicalOp (BSym "<=") = Just (<=)
|
|
logicalOp (BSym "==") = Just (==)
|
|
logicalOp (BSym "!=") = Just (/=)
|
|
logicalOp _ = Nothing
|
|
|
|
|
|
binOp :: Value -> Maybe (Number -> Number -> Number)
|
|
binOp (BSym "*") = Just (*)
|
|
binOp (BSym "/") = Just (/)
|
|
binOp (BSym "+") = Just (+)
|
|
binOp (BSym "-") = Just ( - )
|
|
binOp (BSym "^") = Just (**)
|
|
binOp _ = Nothing
|
|
|
|
|
|
funCall :: State -> Value -> [[Value]] -> (Value, State)
|
|
funCall state (BFun name args body) provided =
|
|
if length args == length provided
|
|
then let
|
|
nstate = callWith state args provided
|
|
(val, _) = eval nstate body
|
|
in (val, state)
|
|
else
|
|
(BErr ("Expected " ++ show (length args) ++
|
|
" arguments in call to function " ++ name ++ ", got " ++
|
|
show (length provided)),
|
|
state)
|
|
where callWith state [] _ = state
|
|
callWith state (a:args) (p:provided) =
|
|
let (evald, nstate) = eval state p
|
|
in callWith (M.insert a evald nstate) args provided
|