diff --git a/a3/a3-handout/a3.cabal b/a3/a3-handout/a3.cabal new file mode 100644 index 0000000..9d3157f --- /dev/null +++ b/a3/a3-handout/a3.cabal @@ -0,0 +1,39 @@ +cabal-version: 3.0 +name: a3 +version: 1.0.0.0 +build-type: Simple + +common common + default-language: Haskell2010 + ghc-options: -Wall + +library + import: common + hs-source-dirs: src + build-depends: + base + , tasty + , tasty-hunit + , megaparsec + exposed-modules: + APL.AST + APL.Eval + APL.Parser + APL.Parser_Tests + +executable apl + import: common + main-is: apl.hs + build-depends: + base + , a3 + +test-suite a3-test + import: common + type: exitcode-stdio-1.0 + main-is: runtests.hs + build-depends: + base + , tasty + , a3 + diff --git a/a3/a3-handout/apl.hs b/a3/a3-handout/apl.hs new file mode 100644 index 0000000..fc57afd --- /dev/null +++ b/a3/a3-handout/apl.hs @@ -0,0 +1,35 @@ +module Main (main) where + +import APL.Eval (Val (..), eval, runEval) +import APL.Parser (parseAPL) +import System.Environment + ( getArgs, + getProgName, + ) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr, stdout) + +stringVal :: Val -> String +stringVal (ValBool b) = show b +stringVal (ValInt x) = show x +stringVal ValFun {} = "#" + +main :: IO () +main = do + args <- getArgs + case args of + [fname] -> do + s <- readFile fname + case parseAPL fname s of + Left err -> hPutStrLn stderr err + Right e -> case runEval (eval e) of + Left err -> hPutStrLn stderr err + Right v -> hPutStrLn stdout $ stringVal v + _ -> do + prog <- getProgName + failure $ "Usage: " ++ prog ++ " FILE" + pure () + where + failure s = do + hPutStrLn stderr s + exitWith $ ExitFailure 1 diff --git a/a3/a3-handout/runtests.hs b/a3/a3-handout/runtests.hs new file mode 100644 index 0000000..56a952e --- /dev/null +++ b/a3/a3-handout/runtests.hs @@ -0,0 +1,5 @@ +import qualified APL.Parser_Tests +import Test.Tasty (defaultMain) + +main :: IO () +main = defaultMain APL.Parser_Tests.tests diff --git a/a3/a3-handout/src/APL/AST.hs b/a3/a3-handout/src/APL/AST.hs new file mode 100644 index 0000000..8ceb5b0 --- /dev/null +++ b/a3/a3-handout/src/APL/AST.hs @@ -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) diff --git a/a3/a3-handout/src/APL/Eval.hs b/a3/a3-handout/src/APL/Eval.hs new file mode 100644 index 0000000..e55dea0 --- /dev/null +++ b/a3/a3-handout/src/APL/Eval.hs @@ -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 diff --git a/a3/a3-handout/src/APL/Parser.hs b/a3/a3-handout/src/APL/Parser.hs new file mode 100644 index 0000000..7652024 --- /dev/null +++ b/a3/a3-handout/src/APL/Parser.hs @@ -0,0 +1,126 @@ +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 + +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" + ] + +pAtom :: Parser Exp +pAtom = + choice + [ CstInt <$> lInteger, + CstBool <$> lBool, + Var <$> lVName, + lString "(" *> pExp <* lString ")" + ] + +pLExp :: Parser Exp +pLExp = + choice + [ If + <$> (lKeyword "if" *> pExp) + <*> (lKeyword "then" *> pExp) + <*> (lKeyword "else" *> pExp), + pAtom + ] + +pExp1 :: Parser Exp +pExp1 = pLExp >>= 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, + 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 diff --git a/a3/a3-handout/src/APL/Parser_Tests.hs b/a3/a3-handout/src/APL/Parser_Tests.hs new file mode 100644 index 0000000..618761a --- /dev/null +++ b/a3/a3-handout/src/APL/Parser_Tests.hs @@ -0,0 +1,68 @@ +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 + ] + ] diff --git a/a3/a3.pdf b/a3/a3.pdf new file mode 100644 index 0000000..869b623 Binary files /dev/null and b/a3/a3.pdf differ