From cd9bd7decd25301a6da01fd97feed1cc33cfabbf Mon Sep 17 00:00:00 2001
From: "Juan J. Martinez" <jjm@usebox.net>
Date: Tue, 6 Sep 2022 22:53:08 +0100
Subject: Typecheck binary operator

---
 src/Compiler.hs  | 32 ++++++++++++++++++--------------
 test/Language.hs | 11 ++++++++++-
 2 files changed, 28 insertions(+), 15 deletions(-)

diff --git a/src/Compiler.hs b/src/Compiler.hs
index ce68c16..2a836ee 100644
--- a/src/Compiler.hs
+++ b/src/Compiler.hs
@@ -81,6 +81,19 @@ typecheckReturn Nothing Nothing = return $ Nothing
 typecheckReturn Nothing fret = return $ Just $ "invalid return value\n     found: ()\n  expected: " ++ showMaybet fret
 typecheckReturn (Just value) fret = typecheckVal value fret
 
+-- | @typecheckBinOp a b pos@ resolves @a@ (left) and compares it to the type
+-- of @b@ via typecheckVal.
+typecheckBinOp :: A.Expr -> A.Expr -> SourcePos -> State CompState CompResult
+typecheckBinOp a b pos = do
+  l <- compile a
+  case l of
+    Right tl -> do
+      tr <- typecheckVal b $ tl
+      case tr of
+        Just err -> addError $ Error TypeError err pos
+        Nothing -> return $ Right $ tl
+    _ -> return $ Right Nothing -- error resolving left
+
 -- built-in types
 types = ["bool", "u8", "s8", "u16", "s16"]
 
@@ -110,21 +123,12 @@ compile x = do
     (A.Module name pos) -> return $ Right Nothing
     (A.Num _ _) -> return $ Right $ Just $ A.Type "u8" -- TODO: placeholder
     (A.Bool' _ _) -> return $ Right $ Just $ A.Type "bool"
-    (A.BinOp A.Assign pos a@(A.Variable _ _) b) -> do
-      l <- compile a
-      case l of
-        Right tl -> do
-          tr <- typecheckVal b $ tl
-          case tr of
-            Just err -> addError $ Error TypeError err pos
-            Nothing -> return $ Right $ tl
-        _ -> return $ Right Nothing -- error resolving left
-    (A.BinOp A.Assign pos _ _) ->
+    (A.BinOp A.Assign pos a@(A.Variable _ _) b) ->
+      typecheckBinOp a b pos
+    (A.BinOp A.Assign pos _ b) ->
       addError $ Error InvalidTarget "invalid assignment target" pos
-    (A.BinOp _ _ a b) -> do
-      l <- compile a
-      r <- compile b
-      return $ l -- TODO: placeholder
+    (A.BinOp op pos a b) ->
+      typecheckBinOp a b pos
     (A.Func ident params ret body priv anon pos) -> do
       -- current env
       (ev, errs) <- get
diff --git a/test/Language.hs b/test/Language.hs
index 0b7d6ac..2347b0e 100644
--- a/test/Language.hs
+++ b/test/Language.hs
@@ -379,6 +379,14 @@ testCaseE16 =
         \a = false;"
         E.TypeError
 
+testCaseE17 =
+  TestLabel "type mismatch in binary operator" $
+    TestCase $
+      expectError
+        "module main\n\
+        \1 + false;\n"
+        E.TypeError
+
 language =
   [ testCase2,
     testCase3,
@@ -412,5 +420,6 @@ language =
     testCaseE13,
     testCaseE14,
     testCaseE15,
-    testCaseE16
+    testCaseE16,
+    testCaseE17
   ]
-- 
cgit v1.2.3