From 69b947f9662a11c77283595482cc71d91c709bc9 Mon Sep 17 00:00:00 2001
From: Nikolaj Gade <nikolaj@ingemanngade.net>
Date: Fri, 20 Sep 2024 16:34:10 +0200
Subject: [PATCH] :white_check_mark: Checking

---
 a2/a2-handout/src/APL/Check.hs       | 80 ++++++++++++++++++++++++++--
 a2/a2-handout/src/APL/Check_Tests.hs | 21 +++++++-
 2 files changed, 97 insertions(+), 4 deletions(-)

diff --git a/a2/a2-handout/src/APL/Check.hs b/a2/a2-handout/src/APL/Check.hs
index 555bdc7..7054fd2 100644
--- a/a2/a2-handout/src/APL/Check.hs
+++ b/a2/a2-handout/src/APL/Check.hs
@@ -1,13 +1,87 @@
 module APL.Check (checkExp, Error) where
 
 import APL.AST (Exp (..), VName)
+import Control.Monad (ap, liftM)
+
+type Vars = [VName]
+
+varsEmpty :: Vars
+varsEmpty = []
 
 type Error = String
 
-newtype CheckM a = CheckM () -- TODO - give this a proper definition.
+newtype CheckM a = CheckM (Vars -> Either Error a)
+
+instance Functor CheckM where
+  fmap = liftM
+
+instance Applicative CheckM where
+  pure x = CheckM $ \_vars -> Right x
+  (<*>) = ap
+
+instance Monad CheckM where
+  CheckM x >>= f = CheckM $ \vars ->
+    case x vars of
+      Left err -> Left err
+      Right x' ->
+        let CheckM y = f x'
+         in y vars
+
+elem' :: VName -> [VName] -> Bool
+elem' _ [] = False
+elem' x (y : ys) = if x == y then True else elem' x ys
+
+askVars :: CheckM Vars
+askVars = CheckM $ \vars -> Right vars
+
+varsExtend :: VName -> Vars -> Vars
+varsExtend v vars = v : vars
+
+localVars :: (Vars -> Vars) -> CheckM a -> CheckM a
+localVars f (CheckM m) = CheckM $ \vars -> m (f vars)
+
+checkBinOp :: Exp -> Exp -> CheckM ()
+checkBinOp e1 e2 = do
+  _ <- check e1
+  check e2
+
+checkTriOp :: Exp -> Exp -> Exp -> CheckM ()
+checkTriOp e1 e2 e3 = do
+  _ <- check e1
+  _ <- check e2
+  check e3
 
 check :: Exp -> CheckM ()
-check = undefined
+check (CstInt _) = CheckM $ \_vars -> pure ()
+check (CstBool _) = CheckM $ \_vars -> pure ()
+check (Add e1 e2) = checkBinOp e1 e2
+check (Sub e1 e2) = checkBinOp e1 e2
+check (Mul e1 e2) = checkBinOp e1 e2
+check (Div e1 e2) = checkBinOp e1 e2
+check (Pow e1 e2) = checkBinOp e1 e2
+check (Eql e1 e2) = checkBinOp e1 e2
+check (If e1 e2 e3) = checkTriOp e1 e2 e3
+check (Apply e1 e2) = checkBinOp e1 e2
+check (TryCatch e1 e2) = checkBinOp e1 e2
+check (Print _ e1) = check e1
+check (KvGet e1) = check e1
+check (KvPut e1 e2) = checkBinOp e1 e2
+check (Var v) = do
+  vars <- askVars
+  if elem' v vars
+    then pure ()
+    else CheckM $ \_vars -> Left $ "Variable not in scope: "++v
+check (Let var e1 e2) = do
+  _ <- check e1
+  localVars (varsExtend var) $ check e2
+check (Lambda var e1) = do
+  localVars (varsExtend var) $ check e1
+
+runCheck :: CheckM a -> Either Error a
+runCheck (CheckM m) = m varsEmpty
 
 checkExp :: Exp -> Maybe Error
-checkExp = undefined
+checkExp e =
+  case runCheck $ check e of
+    Left err -> Just err
+    _ -> Nothing
diff --git a/a2/a2-handout/src/APL/Check_Tests.hs b/a2/a2-handout/src/APL/Check_Tests.hs
index ab32ed4..47590b1 100644
--- a/a2/a2-handout/src/APL/Check_Tests.hs
+++ b/a2/a2-handout/src/APL/Check_Tests.hs
@@ -23,4 +23,23 @@ tests :: TestTree
 tests =
   testGroup
     "Checking"
-    []
+    [
+      testPos (CstBool True),
+      testNeg (Var "x"),
+      testPos (Let "x" (CstInt 3) (CstInt 5)),
+      testPos (Let "x" (CstInt 3) (Var "x")),
+      testNeg (Let "x" (Var "y") (Var "x")),
+      testNeg (Let "x" (CstInt 3) (Var "y")),
+      testPos (Add (Sub (CstInt 9) (CstInt 6)) (CstInt 11)),
+      testPos (Mul (Div (CstInt 9) (CstInt 3)) (CstInt 1)),
+      testNeg (Add (Add (CstInt 1) (Var "x")) (CstInt 1)),
+      testPos (If (CstInt 2) (CstInt 2) (CstInt 2)),
+      testNeg (If (Var "x") (CstInt 2) (CstInt 2)),
+      testNeg (If (CstInt 2) (Var "x") (CstInt 2)),
+      testNeg (If (CstInt 2) (CstInt 2) (Var "x")),
+      testPos (Lambda "x" (CstInt 5)),
+      testPos (Lambda "x" (Var "x")),
+      testNeg (Lambda "x" (Var "y")),
+      testPos (Apply (Lambda "x" (Var "x")) (CstInt 5)),
+      testNeg (Apply (Lambda "x" (Var "x")) (Var "x"))
+    ]