💕 Adding assignment 2

a2/a2-handout/.gitignore

@@ -0,0 +1 @@
+dist-newstyle

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
+

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
+      ]

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)

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

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"
+    []

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

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]