✨
This commit is contained in:
27
a3/src/APL/AST.hs
Normal file
27
a3/src/APL/AST.hs
Normal file
@ -0,0 +1,27 @@
|
||||
module APL.AST
|
||||
( VName,
|
||||
Exp (..),
|
||||
)
|
||||
where
|
||||
|
||||
type VName = String
|
||||
|
||||
data Exp
|
||||
= CstInt Integer
|
||||
| CstBool Bool
|
||||
| Add Exp Exp
|
||||
| Sub Exp Exp
|
||||
| Mul Exp Exp
|
||||
| Div Exp Exp
|
||||
| Pow Exp Exp
|
||||
| Eql Exp Exp
|
||||
| If Exp Exp Exp
|
||||
| Var VName
|
||||
| Let VName Exp Exp
|
||||
| Lambda VName Exp
|
||||
| Apply Exp Exp
|
||||
| TryCatch Exp Exp
|
||||
| Print String Exp
|
||||
| KvPut Exp Exp
|
||||
| KvGet Exp
|
||||
deriving (Eq, Show)
|
||||
132
a3/src/APL/Eval.hs
Normal file
132
a3/src/APL/Eval.hs
Normal file
@ -0,0 +1,132 @@
|
||||
module APL.Eval
|
||||
( Val (..),
|
||||
Env,
|
||||
eval,
|
||||
runEval,
|
||||
Error,
|
||||
)
|
||||
where
|
||||
|
||||
import APL.AST (Exp (..), VName)
|
||||
import Control.Monad (ap, liftM)
|
||||
|
||||
data Val
|
||||
= ValInt Integer
|
||||
| ValBool Bool
|
||||
| ValFun Env VName Exp
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Env = [(VName, Val)]
|
||||
|
||||
envEmpty :: Env
|
||||
envEmpty = []
|
||||
|
||||
envExtend :: VName -> Val -> Env -> Env
|
||||
envExtend v val env = (v, val) : env
|
||||
|
||||
envLookup :: VName -> Env -> Maybe Val
|
||||
envLookup v env = lookup v env
|
||||
|
||||
type Error = String
|
||||
|
||||
newtype EvalM a = EvalM (Env -> Either Error a)
|
||||
|
||||
instance Functor EvalM where
|
||||
fmap = liftM
|
||||
|
||||
instance Applicative EvalM where
|
||||
pure x = EvalM $ \_env -> Right x
|
||||
(<*>) = ap
|
||||
|
||||
instance Monad EvalM where
|
||||
EvalM x >>= f = EvalM $ \env ->
|
||||
case x env of
|
||||
Left err -> Left err
|
||||
Right x' ->
|
||||
let EvalM y = f x'
|
||||
in y env
|
||||
|
||||
askEnv :: EvalM Env
|
||||
askEnv = EvalM $ \env -> Right env
|
||||
|
||||
localEnv :: (Env -> Env) -> EvalM a -> EvalM a
|
||||
localEnv f (EvalM m) = EvalM $ \env -> m (f env)
|
||||
|
||||
failure :: String -> EvalM a
|
||||
failure s = EvalM $ \_env -> Left s
|
||||
|
||||
catch :: EvalM a -> EvalM a -> EvalM a
|
||||
catch (EvalM m1) (EvalM m2) = EvalM $ \env ->
|
||||
case m1 env of
|
||||
Left _ -> m2 env
|
||||
Right x -> Right x
|
||||
|
||||
runEval :: EvalM a -> Either Error a
|
||||
runEval (EvalM m) = m envEmpty
|
||||
|
||||
evalIntBinOp :: (Integer -> Integer -> EvalM Integer) -> Exp -> Exp -> EvalM Val
|
||||
evalIntBinOp f e1 e2 = do
|
||||
v1 <- eval e1
|
||||
v2 <- eval e2
|
||||
case (v1, v2) of
|
||||
(ValInt x, ValInt y) -> ValInt <$> f x y
|
||||
(_, _) -> failure "Non-integer operand"
|
||||
|
||||
evalIntBinOp' :: (Integer -> Integer -> Integer) -> Exp -> Exp -> EvalM Val
|
||||
evalIntBinOp' f e1 e2 =
|
||||
evalIntBinOp f' e1 e2
|
||||
where
|
||||
f' x y = pure $ f x y
|
||||
|
||||
eval :: Exp -> EvalM Val
|
||||
eval (CstInt x) = pure $ ValInt x
|
||||
eval (CstBool b) = pure $ ValBool b
|
||||
eval (Var v) = do
|
||||
env <- askEnv
|
||||
case envLookup v env of
|
||||
Just x -> pure x
|
||||
Nothing -> failure $ "Unknown variable: " ++ v
|
||||
eval (Add e1 e2) = evalIntBinOp' (+) e1 e2
|
||||
eval (Sub e1 e2) = evalIntBinOp' (-) e1 e2
|
||||
eval (Mul e1 e2) = evalIntBinOp' (*) e1 e2
|
||||
eval (Div e1 e2) = evalIntBinOp checkedDiv e1 e2
|
||||
where
|
||||
checkedDiv _ 0 = failure "Division by zero"
|
||||
checkedDiv x y = pure $ x `div` y
|
||||
eval (Pow e1 e2) = evalIntBinOp checkedPow e1 e2
|
||||
where
|
||||
checkedPow x y =
|
||||
if y < 0
|
||||
then failure "Negative exponent"
|
||||
else pure $ x ^ y
|
||||
eval (Eql e1 e2) = do
|
||||
v1 <- eval e1
|
||||
v2 <- eval e2
|
||||
case (v1, v2) of
|
||||
(ValInt x, ValInt y) -> pure $ ValBool $ x == y
|
||||
(ValBool x, ValBool y) -> pure $ ValBool $ x == y
|
||||
(_, _) -> failure "Invalid operands to equality"
|
||||
eval (If cond e1 e2) = do
|
||||
cond' <- eval cond
|
||||
case cond' of
|
||||
ValBool True -> eval e1
|
||||
ValBool False -> eval e2
|
||||
_ -> failure "Non-boolean conditional."
|
||||
eval (Let var e1 e2) = do
|
||||
v1 <- eval e1
|
||||
localEnv (envExtend var v1) $ eval e2
|
||||
eval (Lambda var body) = do
|
||||
env <- askEnv
|
||||
pure $ ValFun env var body
|
||||
eval (Apply e1 e2) = do
|
||||
v1 <- eval e1
|
||||
v2 <- eval e2
|
||||
case (v1, v2) of
|
||||
(ValFun f_env var body, arg) ->
|
||||
localEnv (const $ envExtend var arg f_env) $ eval body
|
||||
(_, _) ->
|
||||
failure "Cannot apply non-function"
|
||||
eval (TryCatch e1 e2) =
|
||||
eval e1 `catch` eval e2
|
||||
eval e =
|
||||
error $ "Evaluation of this expression not implemented:\n" ++ show e
|
||||
185
a3/src/APL/Parser.hs
Normal file
185
a3/src/APL/Parser.hs
Normal file
@ -0,0 +1,185 @@
|
||||
module APL.Parser (parseAPL) where
|
||||
|
||||
import APL.AST (Exp (..), VName)
|
||||
import Control.Monad (void)
|
||||
import Data.Char (isAlpha, isAlphaNum, isDigit)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
( Parsec,
|
||||
choice,
|
||||
chunk,
|
||||
eof,
|
||||
errorBundlePretty,
|
||||
many,
|
||||
notFollowedBy,
|
||||
parse,
|
||||
satisfy,
|
||||
some,
|
||||
try,
|
||||
)
|
||||
import Text.Megaparsec.Char (space)
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
lexeme :: Parser a -> Parser a
|
||||
lexeme p = p <* space
|
||||
|
||||
keywords :: [String]
|
||||
keywords =
|
||||
[ "if",
|
||||
"then",
|
||||
"else",
|
||||
"true",
|
||||
"false",
|
||||
"let",
|
||||
"in",
|
||||
"try",
|
||||
"catch",
|
||||
"print",
|
||||
"put",
|
||||
"get"
|
||||
]
|
||||
|
||||
lVName :: Parser VName
|
||||
lVName = lexeme $ try $ do
|
||||
c <- satisfy isAlpha
|
||||
cs <- many $ satisfy isAlphaNum
|
||||
let v = c : cs
|
||||
if v `elem` keywords
|
||||
then fail "Unexpected keyword"
|
||||
else pure v
|
||||
|
||||
lStringLit :: Parser String
|
||||
lStringLit =
|
||||
lexeme $ many (satisfy (/= '"'))
|
||||
|
||||
lInteger :: Parser Integer
|
||||
lInteger =
|
||||
lexeme $ read <$> some (satisfy isDigit) <* notFollowedBy (satisfy isAlphaNum)
|
||||
|
||||
lString :: String -> Parser ()
|
||||
lString s = lexeme $ void $ chunk s
|
||||
|
||||
lKeyword :: String -> Parser ()
|
||||
lKeyword s = lexeme $ void $ try $ chunk s <* notFollowedBy (satisfy isAlphaNum)
|
||||
|
||||
lBool :: Parser Bool
|
||||
lBool =
|
||||
lexeme . try . choice $
|
||||
[ const True <$> lKeyword "true",
|
||||
const False <$> lKeyword "false"
|
||||
]
|
||||
|
||||
pStringLit :: Parser String
|
||||
pStringLit =
|
||||
lString "\"" *> lStringLit <* lString "\""
|
||||
|
||||
pAtom :: Parser Exp
|
||||
pAtom =
|
||||
choice
|
||||
[ CstInt <$> lInteger,
|
||||
CstBool <$> lBool,
|
||||
Var <$> lVName,
|
||||
lString "(" *> pExp <* lString ")"
|
||||
]
|
||||
|
||||
pFExp :: Parser Exp
|
||||
pFExp = pAtom >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
y <- pAtom
|
||||
chain $ Apply x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pLExp :: Parser Exp
|
||||
pLExp =
|
||||
choice
|
||||
[ If
|
||||
<$> (lKeyword "if" *> pExp)
|
||||
<*> (lKeyword "then" *> pExp)
|
||||
<*> (lKeyword "else" *> pExp),
|
||||
Lambda
|
||||
<$> (lString "\\" *> lVName)
|
||||
<*> (lString "->" *> pExp),
|
||||
TryCatch
|
||||
<$> (lKeyword "try" *> pExp)
|
||||
<*> (lKeyword "catch" *> pExp),
|
||||
Let
|
||||
<$> (lKeyword "let" *> lVName)
|
||||
<*> (lString "=" *> pExp)
|
||||
<*> (lKeyword "in" *> pExp),
|
||||
pFExp
|
||||
]
|
||||
|
||||
pExp3 :: Parser Exp
|
||||
pExp3 =
|
||||
choice
|
||||
[
|
||||
Print
|
||||
<$> (lKeyword "print" *> pStringLit)
|
||||
<*> pAtom,
|
||||
KvGet <$> (lKeyword "get" *> pAtom),
|
||||
KvPut <$> (lKeyword "put" *> pAtom)
|
||||
<*> pAtom,
|
||||
pLExp
|
||||
]
|
||||
|
||||
pExp2 :: Parser Exp
|
||||
pExp2 = pExp3 >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
lString "**"
|
||||
y <- pExp2
|
||||
chain $ Pow x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp1 :: Parser Exp
|
||||
pExp1 = pExp2 >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[
|
||||
do
|
||||
lString "*"
|
||||
y <- pLExp
|
||||
chain $ Mul x y,
|
||||
do
|
||||
lString "/"
|
||||
y <- pLExp
|
||||
chain $ Div x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp0 :: Parser Exp
|
||||
pExp0 = pExp1 >>= chain
|
||||
where
|
||||
chain x =
|
||||
choice
|
||||
[ do
|
||||
lString "+"
|
||||
y <- pExp1
|
||||
chain $ Add x y,
|
||||
do
|
||||
lString "-"
|
||||
y <- pExp1
|
||||
chain $ Sub x y,
|
||||
do
|
||||
lString "=="
|
||||
y <- pExp1
|
||||
chain $ Eql x y,
|
||||
pure x
|
||||
]
|
||||
|
||||
pExp :: Parser Exp
|
||||
pExp = pExp0
|
||||
|
||||
parseAPL :: FilePath -> String -> Either String Exp
|
||||
parseAPL fname s = case parse (space *> pExp <* eof) fname s of
|
||||
Left err -> Left $ errorBundlePretty err
|
||||
Right x -> Right x
|
||||
116
a3/src/APL/Parser_Tests.hs
Normal file
116
a3/src/APL/Parser_Tests.hs
Normal file
@ -0,0 +1,116 @@
|
||||
module APL.Parser_Tests (tests) where
|
||||
|
||||
import APL.AST (Exp (..))
|
||||
import APL.Parser (parseAPL)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit (assertFailure, testCase, (@?=))
|
||||
|
||||
parserTest :: String -> Exp -> TestTree
|
||||
parserTest s e =
|
||||
testCase s $
|
||||
case parseAPL "input" s of
|
||||
Left err -> assertFailure err
|
||||
Right e' -> e' @?= e
|
||||
|
||||
parserTestFail :: String -> TestTree
|
||||
parserTestFail s =
|
||||
testCase s $
|
||||
case parseAPL "input" s of
|
||||
Left _ -> pure ()
|
||||
Right e ->
|
||||
assertFailure $
|
||||
"Expected parse error but received this AST:\n" ++ show e
|
||||
|
||||
tests :: TestTree
|
||||
tests =
|
||||
testGroup
|
||||
"Parsing"
|
||||
[ testGroup
|
||||
"Constants"
|
||||
[ parserTest "123" $ CstInt 123,
|
||||
parserTest " 123" $ CstInt 123,
|
||||
parserTest "123 " $ CstInt 123,
|
||||
parserTestFail "123f",
|
||||
parserTest "true" $ CstBool True,
|
||||
parserTest "false" $ CstBool False
|
||||
],
|
||||
testGroup
|
||||
"Basic operators"
|
||||
[ parserTest "x+y" $ Add (Var "x") (Var "y"),
|
||||
parserTest "x-y" $ Sub (Var "x") (Var "y"),
|
||||
parserTest "x*y" $ Mul (Var "x") (Var "y"),
|
||||
parserTest "x/y" $ Div (Var "x") (Var "y")
|
||||
],
|
||||
testGroup
|
||||
"Operator priority"
|
||||
[ parserTest "x+y+z" $ Add (Add (Var "x") (Var "y")) (Var "z"),
|
||||
parserTest "x+y-z" $ Sub (Add (Var "x") (Var "y")) (Var "z"),
|
||||
parserTest "x+y*z" $ Add (Var "x") (Mul (Var "y") (Var "z")),
|
||||
parserTest "x*y*z" $ Mul (Mul (Var "x") (Var "y")) (Var "z"),
|
||||
parserTest "x/y/z" $ Div (Div (Var "x") (Var "y")) (Var "z")
|
||||
],
|
||||
testGroup
|
||||
"Conditional expressions"
|
||||
[ parserTest "if x then y else z" $ If (Var "x") (Var "y") (Var "z"),
|
||||
parserTest "if x then y else if x then y else z" $
|
||||
If (Var "x") (Var "y") $
|
||||
If (Var "x") (Var "y") (Var "z"),
|
||||
parserTest "if x then (if x then y else z) else z" $
|
||||
If (Var "x") (If (Var "x") (Var "y") (Var "z")) (Var "z"),
|
||||
parserTest "1 + if x then y else z" $
|
||||
Add (CstInt 1) (If (Var "x") (Var "y") (Var "z"))
|
||||
],
|
||||
testGroup
|
||||
"Lexing edge cases"
|
||||
[ parserTest "2 " $ CstInt 2,
|
||||
parserTest " 2" $ CstInt 2
|
||||
],
|
||||
testGroup
|
||||
"FExp"
|
||||
[ parserTest "x y" $ Apply (Var "x") (Var "y"),
|
||||
parserTest "x y z" $ Apply (Apply (Var "x") (Var "y")) (Var "z"),
|
||||
parserTest "x y z+5" $ Add (Apply (Apply (Var "x") (Var "y")) (Var "z")) (CstInt 5),
|
||||
parserTest "x (y z)" $ Apply (Var "x") (Apply (Var "y") (Var "z"))
|
||||
],
|
||||
testGroup
|
||||
"Eql"
|
||||
[ parserTest "x == y" $ Eql (Var "x") (Var "y"),
|
||||
parserTest "x == y == z" $ Eql (Eql (Var "x") (Var "y")) (Var "z"),
|
||||
parserTest "x + y == z * x" $ Eql (Add (Var "x") (Var "y")) (Mul (Var "z") (Var "x"))
|
||||
],
|
||||
testGroup
|
||||
"Pow"
|
||||
[ parserTest "x ** y" $ Pow (Var "x") (Var "y"),
|
||||
parserTest "x ** y ** z" $ Pow (Var "x") (Pow (Var "y") (Var "z")),
|
||||
parserTest "x + y ** z * x" $ Add (Var "x") (Mul (Pow (Var "y") (Var "z")) (Var "x"))
|
||||
],
|
||||
testGroup
|
||||
"Print"
|
||||
[ parserTest "print \"test\" x" $ Print "test" (Var "x"),
|
||||
parserTest "print \"7\" x" $ Print "7" (Var "x"),
|
||||
parserTest "print \"cool_print\" x" $ Print "cool_print" (Var "x"),
|
||||
parserTest "print \"\" x" $ Print "" (Var "x")
|
||||
],
|
||||
testGroup
|
||||
"Get"
|
||||
[ parserTest "get x" $ KvGet (Var "x"),
|
||||
parserTest "get 1" $ KvGet (CstInt 1)
|
||||
],
|
||||
testGroup
|
||||
"Put"
|
||||
[ parserTest "put x y" $ KvPut (Var "x") (Var "y")
|
||||
],
|
||||
testGroup
|
||||
"Lambda"
|
||||
[ parserTest "\\x->y" $ Lambda "x" (Var "y"),
|
||||
parserTest "\\x->y+z+5" $ Lambda "x" (Add (Add (Var "y") (Var "z")) (CstInt 5))
|
||||
],
|
||||
testGroup
|
||||
"TryCatch"
|
||||
[ parserTest "try x catch y" $ TryCatch (Var "x") (Var "y")
|
||||
],
|
||||
testGroup
|
||||
"Let"
|
||||
[ parserTest "let x=5 in y" $ Let "x" (CstInt 5) (Var "y")
|
||||
]
|
||||
]
|
||||
Reference in New Issue
Block a user