diff --git a/a5/a5-handout/a5.cabal b/a5/a5-handout/a5.cabal new file mode 100644 index 0000000..f7d30f3 --- /dev/null +++ b/a5/a5-handout/a5.cabal @@ -0,0 +1,41 @@ +cabal-version: 3.0 +name: a5 +version: 1.0.0.0 +build-type: Simple + +common common + default-language: Haskell2010 + ghc-options: -Wall -Wno-orphans + +library + import: common + hs-source-dirs: src + build-depends: + base + , megaparsec + , QuickCheck + exposed-modules: + APL.AST + APL.Parser + APL.Error + APL.Eval + APL.Check + APL.Tests + +executable apl + import: common + main-is: apl.hs + build-depends: + base + , a5 + +test-suite a5-test + import: common + type: exitcode-stdio-1.0 + main-is: runtests.hs + build-depends: + base + , tasty + , tasty-quickcheck + , a5 + diff --git a/a5/a5-handout/apl.hs b/a5/a5-handout/apl.hs new file mode 100644 index 0000000..ff2bdd2 --- /dev/null +++ b/a5/a5-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 $ show err + Right v -> hPutStrLn stdout $ stringVal v + _ -> do + prog <- getProgName + failure $ "Usage: " ++ prog ++ " FILE" + pure () + where + failure e = do + hPutStrLn stderr $ show e + exitWith $ ExitFailure 1 diff --git a/a5/a5-handout/runtests.hs b/a5/a5-handout/runtests.hs new file mode 100644 index 0000000..d7020aa --- /dev/null +++ b/a5/a5-handout/runtests.hs @@ -0,0 +1,6 @@ +import qualified APL.Tests +import Test.Tasty (defaultMain) +import Test.Tasty.QuickCheck (testProperties) + +main :: IO () +main = defaultMain (testProperties "APL properties" APL.Tests.properties) diff --git a/a5/a5-handout/src/APL/AST.hs b/a5/a5-handout/src/APL/AST.hs new file mode 100644 index 0000000..e64fa83 --- /dev/null +++ b/a5/a5-handout/src/APL/AST.hs @@ -0,0 +1,82 @@ +module APL.AST + ( VName + , Exp (..) + , printExp + , subExp + ) +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 + deriving (Eq, Show) + +parens :: String -> String +parens x = "(" ++ x ++ ")" + +printBinOp :: String -> Exp -> Exp -> String +printBinOp op x y = parens $ printExp x ++ " " ++ op ++ " " ++ printExp y + +printExp :: Exp -> String +printExp (CstInt x) = show x +printExp (CstBool b) = if b then "true" else "false" +printExp (Add x y) = printBinOp "+" x y +printExp (Sub x y) = printBinOp "-" x y +printExp (Mul x y) = printBinOp "*" x y +printExp (Div x y) = printBinOp "/" x y +printExp (Pow x y) = printBinOp "**" x y +printExp (Eql x y) = printBinOp "==" x y +printExp (If x y z) = + parens $ + "if " + ++ printExp x + ++ " then " + ++ printExp y + ++ " else " + ++ printExp z +printExp (Var v) = v +printExp (Let v e1 e2) = + parens $ + "let " + ++ v + ++ " = " + ++ printExp e1 + ++ " in " + ++ printExp e2 +printExp (Lambda v body) = + parens $ "\\" ++ v ++ " -> " ++ printExp body +printExp (Apply x y) = + printExp x ++ " " ++ printExp y +printExp (TryCatch x y) = + "try " ++ printExp x ++ " catch " ++ printExp y + +subExp :: Exp -> [Exp] +subExp e = e : case e of + CstInt _ -> [] + CstBool _ -> [] + Add e1 e2 -> subExp e1 ++ subExp e2 + Sub e1 e2 -> subExp e1 ++ subExp e2 + Mul e1 e2 -> subExp e1 ++ subExp e2 + Div e1 e2 -> subExp e1 ++ subExp e2 + Pow e1 e2 -> subExp e1 ++ subExp e2 + Eql e1 e2 -> subExp e1 ++ subExp e2 + If e0 e1 e2 -> subExp e0 ++ subExp e1 ++ subExp e2 + Var _ -> [] + Let _ e1 e2 -> subExp e1 ++ subExp e2 + Lambda _ body -> subExp body + Apply e1 e2 -> subExp e1 ++ subExp e2 + TryCatch e1 e2 -> subExp e1 ++ subExp e2 diff --git a/a5/a5-handout/src/APL/Check.hs b/a5/a5-handout/src/APL/Check.hs new file mode 100644 index 0000000..9401888 --- /dev/null +++ b/a5/a5-handout/src/APL/Check.hs @@ -0,0 +1,92 @@ +module APL.Check (checkExp, Error) where + +import APL.AST (Exp (..), VName) +import APL.Error (Error (..)) +import Control.Monad (ap, liftM, unless) +import Data.List (union) + +type Vars = [VName] + +newtype CheckM a = CheckM {runCheckM :: Vars -> (a, [Error])} + +instance Functor CheckM where + fmap = liftM + +instance Applicative CheckM where + (<*>) = ap + pure x = CheckM $ \_ -> (x, []) + +instance Monad CheckM where + CheckM x >>= f = CheckM $ \vars -> + let (y, errs1) = x vars + (z, errs2) = runCheckM (f y) vars + in (z, union errs1 errs2) + +askVars :: CheckM Vars +askVars = CheckM $ \vars -> (vars, []) + +localVars :: (Vars -> Vars) -> CheckM a -> CheckM a +localVars f m = CheckM $ \vars -> + runCheckM m (f vars) + +failure :: Error -> CheckM () +failure err = CheckM $ \_ -> ((), [err]) + +maskErrors :: CheckM a -> CheckM a +maskErrors m = CheckM $ \vars -> + let (x, _) = runCheckM m vars in (x, []) + +check :: Exp -> CheckM () +check (CstInt _) = pure () +check (CstBool _) = pure () +check (Var v) = do + vars <- askVars + unless (v `elem` vars) $ + failure $ + UnknownVariable v +check (Add x y) = do + failure NonInteger + check x + check y +check (Sub x y) = do + failure NonInteger + check x + check y +check (Mul x y) = do + failure NonInteger + check x + check y +check (Div x y) = do + failure NonInteger + failure DivisionByZero + check x + check y +check (Pow x y) = do + failure NonInteger + failure NegativeExponent + check x + check y +check (Eql x y) = do + failure InvalidEqual + check x + check y +check (If x y z) = do + failure NonBoolean + check x + check y + check z +check (Let v e1 e2) = do + check e1 + localVars (v :) $ check e2 +check (Lambda v e) = do + localVars (v :) $ check e +check (Apply x y) = do + failure NonFunction + check x + check y +check (TryCatch x y) = do + maskErrors $ check x + check y + +checkExp :: Exp -> [Error] +checkExp e = snd $ runCheckM (check e) [] diff --git a/a5/a5-handout/src/APL/Error.hs b/a5/a5-handout/src/APL/Error.hs new file mode 100644 index 0000000..77cee5b --- /dev/null +++ b/a5/a5-handout/src/APL/Error.hs @@ -0,0 +1,35 @@ +module APL.Error + ( Error(..) + , isVariableError + , isDomainError + , isTypeError + ) +where + +import APL.AST (VName) + +data Error + = NonInteger + | UnknownVariable VName + | DivisionByZero + | NegativeExponent + | InvalidEqual + | NonBoolean + | NonFunction + deriving (Show, Eq) + +isVariableError :: Error -> Bool +isVariableError (UnknownVariable _) = True +isVariableError _ = False + +isDomainError :: Error -> Bool +isDomainError DivisionByZero = True +isDomainError NegativeExponent = True +isDomainError _ = False + +isTypeError :: Error -> Bool +isTypeError NonInteger = True +isTypeError InvalidEqual = True +isTypeError NonBoolean = True +isTypeError NonFunction = True +isTypeError _ = False diff --git a/a5/a5-handout/src/APL/Eval.hs b/a5/a5-handout/src/APL/Eval.hs new file mode 100644 index 0000000..37d1ce0 --- /dev/null +++ b/a5/a5-handout/src/APL/Eval.hs @@ -0,0 +1,128 @@ +module APL.Eval + ( Val (..), + Env, + eval, + runEval, + ) +where + +import APL.AST (Exp (..), VName) +import APL.Error (Error (..)) +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 + +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 :: Error -> 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 NonInteger + +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 $ UnknownVariable 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 DivisionByZero + checkedDiv x y = pure $ x `div` y +eval (Pow e1 e2) = evalIntBinOp checkedPow e1 e2 + where + checkedPow x y = + if y < 0 + then failure NegativeExponent + 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 InvalidEqual +eval (If cond e1 e2) = do + cond' <- eval cond + case cond' of + ValBool True -> eval e1 + ValBool False -> eval e2 + _ -> failure NonBoolean +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 NonFunction +eval (TryCatch e1 e2) = + eval e1 `catch` eval e2 diff --git a/a5/a5-handout/src/APL/Parser.hs b/a5/a5-handout/src/APL/Parser.hs new file mode 100644 index 0000000..d58c41d --- /dev/null +++ b/a5/a5-handout/src/APL/Parser.hs @@ -0,0 +1,168 @@ +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" + ] + +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 ")" + ] + +pFExp :: Parser Exp +pFExp = chain =<< pAtom + 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 + ] + +pExp4 :: Parser Exp +pExp4 = pLExp >>= chain + where + chain x = + choice + [ do + lString "**" + y <- pLExp + Pow x <$> chain y, + pure x + ] + +pExp3 :: Parser Exp +pExp3 = pExp4 >>= chain + where + chain x = + choice + [ do + lString "*" + y <- pExp4 + chain $ Mul x y, + do + lString "/" + y <- pExp4 + chain $ Div x y, + pure x + ] + +pExp2 :: Parser Exp +pExp2 = pExp3 >>= chain + where + chain x = + choice + [ do + lString "+" + y <- pExp3 + chain $ Add x y, + do + lString "-" + y <- pExp3 + chain $ Sub x y, + pure x + ] + +pExp1 :: Parser Exp +pExp1 = pExp2 >>= chain + where + chain x = + choice + [ do + lString "==" + y <- pExp2 + chain $ Eql x y, + pure x + ] + +pExp :: Parser Exp +pExp = pExp1 + +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/a5/a5-handout/src/APL/Tests.hs b/a5/a5-handout/src/APL/Tests.hs new file mode 100644 index 0000000..7ab874e --- /dev/null +++ b/a5/a5-handout/src/APL/Tests.hs @@ -0,0 +1,92 @@ +module APL.Tests + ( properties + ) +where + +import APL.AST (Exp (..), subExp) +import APL.Error (isVariableError, isDomainError, isTypeError) +import APL.Check (checkExp) +import Test.QuickCheck + ( Property + , Gen + , Arbitrary (arbitrary, shrink) + , property + , cover + , checkCoverage + , oneof + , sized + ) + +instance Arbitrary Exp where + arbitrary = sized genExp + + shrink (Add e1 e2) = + e1 : e2 : [Add e1' e2 | e1' <- shrink e1] ++ [Add e1 e2' | e2' <- shrink e2] + shrink (Sub e1 e2) = + e1 : e2 : [Sub e1' e2 | e1' <- shrink e1] ++ [Sub e1 e2' | e2' <- shrink e2] + shrink (Mul e1 e2) = + e1 : e2 : [Mul e1' e2 | e1' <- shrink e1] ++ [Mul e1 e2' | e2' <- shrink e2] + shrink (Div e1 e2) = + e1 : e2 : [Div e1' e2 | e1' <- shrink e1] ++ [Div e1 e2' | e2' <- shrink e2] + shrink (Pow e1 e2) = + e1 : e2 : [Pow e1' e2 | e1' <- shrink e1] ++ [Pow e1 e2' | e2' <- shrink e2] + shrink (Eql e1 e2) = + e1 : e2 : [Eql e1' e2 | e1' <- shrink e1] ++ [Eql e1 e2' | e2' <- shrink e2] + shrink (If cond e1 e2) = + e1 : e2 : [If cond' e1 e2 | cond' <- shrink cond] ++ [If cond e1' e2 | e1' <- shrink e1] ++ [If cond e1 e2' | e2' <- shrink e2] + shrink (Let x e1 e2) = + e1 : [Let x e1' e2 | e1' <- shrink e1] ++ [Let x e1 e2' | e2' <- shrink e2] + shrink (Lambda x e) = + [Lambda x e' | e' <- shrink e] + shrink (Apply e1 e2) = + e1 : e2 : [Apply e1' e2 | e1' <- shrink e1] ++ [Apply e1 e2' | e2' <- shrink e2] + shrink (TryCatch e1 e2) = + e1 : e2 : [TryCatch e1' e2 | e1' <- shrink e1] ++ [TryCatch e1 e2' | e2' <- shrink e2] + shrink _ = [] + +genExp :: Int -> Gen Exp +genExp 0 = oneof [CstInt <$> arbitrary, CstBool <$> arbitrary] +genExp size = + oneof + [ CstInt <$> arbitrary + , CstBool <$> arbitrary + , Add <$> genExp halfSize <*> genExp halfSize + , Sub <$> genExp halfSize <*> genExp halfSize + , Mul <$> genExp halfSize <*> genExp halfSize + , Div <$> genExp halfSize <*> genExp halfSize + , Pow <$> genExp halfSize <*> genExp halfSize + , Eql <$> genExp halfSize <*> genExp halfSize + , If <$> genExp thirdSize <*> genExp thirdSize <*> genExp thirdSize + , Var <$> arbitrary + , Let <$> arbitrary <*> genExp halfSize <*> genExp halfSize + , Lambda <$> arbitrary <*> genExp (size - 1) + , Apply <$> genExp halfSize <*> genExp halfSize + , TryCatch <$> genExp halfSize <*> genExp halfSize + ] + where + halfSize = size `div` 2 + thirdSize = size `div` 3 + +expCoverage :: Exp -> Property +expCoverage e = checkCoverage + . cover 20 (any isDomainError (checkExp e)) "domain error" + . cover 20 (not $ any isDomainError (checkExp e)) "no domain error" + . cover 20 (any isTypeError (checkExp e)) "type error" + . cover 20 (not $ any isTypeError (checkExp e)) "no type error" + . cover 5 (any isVariableError (checkExp e)) "variable error" + . cover 70 (not $ any isVariableError (checkExp e)) "no variable error" + . cover 50 (or [2 <= n && n <= 4 | Var v <- subExp e, let n = length v]) "non-trivial variable" + $ () + +parsePrinted :: Exp -> Bool +parsePrinted _ = undefined + +onlyCheckedErrors :: Exp -> Bool +onlyCheckedErrors _ = undefined + +properties :: [(String, Property)] +properties = + [ ("expCoverage", property expCoverage) + , ("onlyCheckedErrors", property onlyCheckedErrors) + , ("parsePrinted", property parsePrinted) + ] diff --git a/a5/a5.pdf b/a5/a5.pdf new file mode 100644 index 0000000..e980817 Binary files /dev/null and b/a5/a5.pdf differ