add other arithmetic operators
This commit is contained in:
parent
1aad8057a0
commit
d36f589132
2
ast.hs
2
ast.hs
|
@ -1,7 +1,9 @@
|
||||||
module AST where
|
module AST where
|
||||||
|
|
||||||
data AST = Add AST AST
|
data AST = Add AST AST
|
||||||
|
| Sub AST AST
|
||||||
| Mul AST AST
|
| Mul AST AST
|
||||||
|
| Div AST AST
|
||||||
| Block [AST]
|
| Block [AST]
|
||||||
| FunDef String ([Pattern], AST)
|
| FunDef String ([Pattern], AST)
|
||||||
| Defun String AST
|
| Defun String AST
|
||||||
|
|
18
interp.hs
18
interp.hs
|
@ -30,10 +30,20 @@ lookup env name = M.lookup name env
|
||||||
bind :: Env -> String -> Value -> Env
|
bind :: Env -> String -> Value -> Env
|
||||||
bind env name value = M.insert name value env
|
bind env name value = M.insert name value env
|
||||||
|
|
||||||
|
-- value operators
|
||||||
(IntV l) +$ (IntV r) = IntV (l + r)
|
(IntV l) +$ (IntV r) = IntV (l + r)
|
||||||
(StrV l) +$ (StrV r) = StrV (l ++ r)
|
(StrV l) +$ (StrV r) = StrV (l ++ r)
|
||||||
l +$ r = error $ "cannot + " ++ show l ++ " and " ++ show 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
|
-- these are pretty nasty and instead of using unsafePerformIO
|
||||||
-- we could throw eval, etc. into StateT with IO instead, but then
|
-- we could throw eval, etc. into StateT with IO instead, but then
|
||||||
-- everything would be in IO.
|
-- everything would be in IO.
|
||||||
|
@ -103,10 +113,10 @@ eval (Def name v') = do
|
||||||
eval (Lambda pats) =
|
eval (Lambda pats) =
|
||||||
return $ FnV pats
|
return $ FnV pats
|
||||||
|
|
||||||
eval (Add l r) = do
|
eval (Add l r) = do { l <- eval l; r <- eval r; return $ l +$ r }
|
||||||
l <- eval l
|
eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r }
|
||||||
r <- eval r
|
eval (Mul l r) = do { l <- eval l; r <- eval r; return $ l *$ r }
|
||||||
return $ l +$ r
|
eval (Div l r) = do { l <- eval l; r <- eval r; return $ l /$ r }
|
||||||
|
|
||||||
eval (Call name args) = get >>= \(_,env) ->
|
eval (Call name args) = get >>= \(_,env) ->
|
||||||
case lookup env name of
|
case lookup env name of
|
||||||
|
|
|
@ -14,12 +14,14 @@ languageDef = emptyDef {T.commentStart="{-",
|
||||||
T.identStart = letter <|> char '_',
|
T.identStart = letter <|> char '_',
|
||||||
T.identLetter = alphaNum <|> char '_',
|
T.identLetter = alphaNum <|> char '_',
|
||||||
T.reservedNames = ["do", "end"],
|
T.reservedNames = ["do", "end"],
|
||||||
T.reservedOpNames = ["+", "*"]}
|
T.reservedOpNames = ["+", "-", "*", "/"]}
|
||||||
|
|
||||||
lexer = T.makeTokenParser languageDef
|
lexer = T.makeTokenParser languageDef
|
||||||
exprparser = buildExpressionParser ops term <?> "expression"
|
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 Add) AssocLeft]
|
||||||
|
, [Infix (reservedOp "-" >> return Sub) AssocLeft]
|
||||||
]
|
]
|
||||||
|
|
||||||
identifier = T.identifier lexer
|
identifier = T.identifier lexer
|
||||||
|
|
Loading…
Reference in New Issue