diff --git a/ast.hs b/ast.hs index 53dfdee..360441f 100644 --- a/ast.hs +++ b/ast.hs @@ -1,7 +1,9 @@ module AST where data AST = Add AST AST + | Sub AST AST | Mul AST AST + | Div AST AST | Block [AST] | FunDef String ([Pattern], AST) | Defun String AST diff --git a/interp.hs b/interp.hs index aa9d484..2fad473 100644 --- a/interp.hs +++ b/interp.hs @@ -30,10 +30,20 @@ lookup env name = M.lookup name env bind :: Env -> String -> Value -> Env bind env name value = M.insert name value env +-- value operators (IntV l) +$ (IntV r) = IntV (l + r) (StrV l) +$ (StrV r) = StrV (l ++ r) l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show r +(IntV l) -$ (IntV r) = IntV (l - r) +l -$ r = error $ "cannot - " ++ show l ++ " and " ++ show r + +(IntV l) *$ (IntV r) = IntV (l * r) +l *$ r = error $ "cannot * " ++ show l ++ " and " ++ show r + +(IntV l) /$ (IntV r) = IntV (l `div` r) +l /$ r = error $ "cannot / " ++ show l ++ " and " ++ show r + -- these are pretty nasty and instead of using unsafePerformIO -- we could throw eval, etc. into StateT with IO instead, but then -- everything would be in IO. @@ -103,10 +113,10 @@ eval (Def name v') = do eval (Lambda pats) = return $ FnV pats -eval (Add l r) = do - l <- eval l - r <- eval r - return $ l +$ r +eval (Add l r) = do { l <- eval l; r <- eval r; return $ l +$ r } +eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r } +eval (Mul l r) = do { l <- eval l; r <- eval r; return $ l *$ r } +eval (Div l r) = do { l <- eval l; r <- eval r; return $ l /$ r } eval (Call name args) = get >>= \(_,env) -> case lookup env name of diff --git a/parser.hs b/parser.hs index 06bea11..8477530 100644 --- a/parser.hs +++ b/parser.hs @@ -14,12 +14,14 @@ languageDef = emptyDef {T.commentStart="{-", T.identStart = letter <|> char '_', T.identLetter = alphaNum <|> char '_', T.reservedNames = ["do", "end"], - T.reservedOpNames = ["+", "*"]} + T.reservedOpNames = ["+", "-", "*", "/"]} lexer = T.makeTokenParser languageDef exprparser = buildExpressionParser ops term "expression" -ops = [ [Infix (reservedOp "*" >> return Mul) AssocLeft ] +ops = [ [Infix (reservedOp "*" >> return Mul) AssocLeft] + , [Infix (reservedOp "/" >> return Div) AssocLeft] , [Infix (reservedOp "+" >> return Add) AssocLeft] + , [Infix (reservedOp "-" >> return Sub) AssocLeft] ] identifier = T.identifier lexer