diff --git a/a2/a2-handout/.gitignore b/a2/a2-handout/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/a2/a2-handout/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/a2/a2-handout/a2.cabal b/a2/a2-handout/a2.cabal new file mode 100644 index 0000000..faed259 --- /dev/null +++ b/a2/a2-handout/a2.cabal @@ -0,0 +1,32 @@ +cabal-version: 3.0 +name: a2 +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 + exposed-modules: + APL.AST + APL.Check + APL.Check_Tests + APL.Eval + APL.Eval_Tests + +test-suite a2-test + import: common + type: exitcode-stdio-1.0 + main-is: runtests.hs + build-depends: + base + , tasty + , a2 + diff --git a/a2/a2-handout/runtests.hs b/a2/a2-handout/runtests.hs new file mode 100644 index 0000000..2bd94e9 --- /dev/null +++ b/a2/a2-handout/runtests.hs @@ -0,0 +1,12 @@ +import qualified APL.Check_Tests +import qualified APL.Eval_Tests +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "APL" + [ APL.Eval_Tests.tests, + APL.Check_Tests.tests + ] diff --git a/a2/a2-handout/src/APL/AST.hs b/a2/a2-handout/src/APL/AST.hs new file mode 100644 index 0000000..4aa7620 --- /dev/null +++ b/a2/a2-handout/src/APL/AST.hs @@ -0,0 +1,24 @@ +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 + deriving (Eq, Show) diff --git a/a2/a2-handout/src/APL/Check.hs b/a2/a2-handout/src/APL/Check.hs new file mode 100644 index 0000000..555bdc7 --- /dev/null +++ b/a2/a2-handout/src/APL/Check.hs @@ -0,0 +1,13 @@ +module APL.Check (checkExp, Error) where + +import APL.AST (Exp (..), VName) + +type Error = String + +newtype CheckM a = CheckM () -- TODO - give this a proper definition. + +check :: Exp -> CheckM () +check = undefined + +checkExp :: Exp -> Maybe Error +checkExp = undefined diff --git a/a2/a2-handout/src/APL/Check_Tests.hs b/a2/a2-handout/src/APL/Check_Tests.hs new file mode 100644 index 0000000..ab32ed4 --- /dev/null +++ b/a2/a2-handout/src/APL/Check_Tests.hs @@ -0,0 +1,26 @@ +module APL.Check_Tests (tests) where + +import APL.AST (Exp (..)) +import APL.Check (checkExp) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +-- Assert that the provided expression should pass the type checker. +testPos :: Exp -> TestTree +testPos e = + testCase (show e) $ + checkExp e @?= Nothing + +-- Assert that the provided expression should fail the type checker. +testNeg :: Exp -> TestTree +testNeg e = + testCase (show e) $ + case checkExp e of + Nothing -> assertFailure "expected error" + Just _ -> pure () + +tests :: TestTree +tests = + testGroup + "Checking" + [] diff --git a/a2/a2-handout/src/APL/Eval.hs b/a2/a2-handout/src/APL/Eval.hs new file mode 100644 index 0000000..3a51d87 --- /dev/null +++ b/a2/a2-handout/src/APL/Eval.hs @@ -0,0 +1,129 @@ +module APL.Eval + ( Val (..), + 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 diff --git a/a2/a2-handout/src/APL/Eval_Tests.hs b/a2/a2-handout/src/APL/Eval_Tests.hs new file mode 100644 index 0000000..41ce5bd --- /dev/null +++ b/a2/a2-handout/src/APL/Eval_Tests.hs @@ -0,0 +1,84 @@ +module APL.Eval_Tests (tests) where + +import APL.AST (Exp (..)) +import APL.Eval (Error, Val (..), eval, runEval) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +eval' :: Exp -> Either Error Val +eval' = runEval . eval + +evalTests :: TestTree +evalTests = + testGroup + "EValuation" + [ testCase "Add" $ + eval' (Add (CstInt 2) (CstInt 5)) + @?= Right (ValInt 7), + -- + testCase "Add (wrong type)" $ + eval' (Add (CstInt 2) (CstBool True)) + @?= Left "Non-integer operand", + -- + testCase "Sub" $ + eval' (Sub (CstInt 2) (CstInt 5)) + @?= Right (ValInt (-3)), + -- + testCase "Div" $ + eval' (Div (CstInt 7) (CstInt 3)) + @?= Right (ValInt 2), + -- + testCase "Div0" $ + eval' (Div (CstInt 7) (CstInt 0)) + @?= Left "Division by zero", + -- + testCase "Pow" $ + eval' (Pow (CstInt 2) (CstInt 3)) + @?= Right (ValInt 8), + -- + testCase "Pow0" $ + eval' (Pow (CstInt 2) (CstInt 0)) + @?= Right (ValInt 1), + -- + testCase "Pow negative" $ + eval' (Pow (CstInt 2) (CstInt (-1))) + @?= Left "Negative exponent", + -- + testCase "Eql (false)" $ + eval' (Eql (CstInt 2) (CstInt 3)) + @?= Right (ValBool False), + -- + testCase "Eql (true)" $ + eval' (Eql (CstInt 2) (CstInt 2)) + @?= Right (ValBool True), + -- + testCase "If" $ + eval' (If (CstBool True) (CstInt 2) (Div (CstInt 7) (CstInt 0))) + @?= Right (ValInt 2), + -- + testCase "Let" $ + eval' (Let "x" (Add (CstInt 2) (CstInt 3)) (Var "x")) + @?= Right (ValInt 5), + -- + testCase "Let (shadowing)" $ + eval' + ( Let + "x" + (Add (CstInt 2) (CstInt 3)) + (Let "x" (CstBool True) (Var "x")) + ) + @?= Right (ValBool True), + -- + testCase "Lambda/Apply" $ + eval' + (Apply (Lambda "x" (Mul (Var "x") (Var "x"))) (CstInt 4)) + @?= Right (ValInt 16), + -- + testCase "TryCatch" $ + eval' + (TryCatch (Div (CstInt 7) (CstInt 0)) (CstBool True)) + @?= Right (ValBool True) + ] + +tests :: TestTree +tests = testGroup "APL" [evalTests] diff --git a/a2/a2.pdf b/a2/a2.pdf new file mode 100644 index 0000000..e74d2c7 Binary files /dev/null and b/a2/a2.pdf differ