add typecheck method and constructor call

src/Typecheck.hs

@@ -1,5 +1,6 @@
 module Typecheck where
 import Data.List (find)
+import Data.Maybe
 import Ast
 
 typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
@@ -10,7 +11,9 @@ typeCheckClass (Class className methods fields) classes =
     let
         -- Create a symbol table from class fields
         classFields = [(id, dt) | VariableDeclaration dt id _ <- fields]
-        checkedMethods = map (\method -> typeCheckMethodDeclaration method classFields classes) methods
+        methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
+        initalSymTab = ("this", className) : classFields ++ methodEntries
+        checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
     in Class className checkedMethods fields
 
 typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
@@ -137,20 +140,20 @@ typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
         NameResolution ->
           case (expr1', expr2) of
               (TypedExpression t1 (Reference obj), Reference member) ->
-                -- Lookup the class type of obj from the symbol table
                   let objectType = lookupType obj symtab
                       classDetails = find (\(Class className _ _) -> className == objectType) classes
                   in case classDetails of
-                    Just (Class _ methods fields) ->
+                      Just (Class _ _ fields) ->
-                        -- Check both fields and methods to find a match for member
                           let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member]
-                            methodTypes = [dt | MethodDeclaration dt id _ _ <- methods, id == member]
+                          in case fieldTypes of
-                        in case fieldTypes ++ methodTypes of
+                              [resolvedType] -> TypedExpression resolvedType (Reference member)
-                            [resolvedType] -> TypedExpression resolvedType (BinaryOperation op expr1' (TypedExpression resolvedType (Reference member)))
+                              [] -> error $ "Field '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
-                            [] -> error $ "Member '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
+                              _ -> error $ "Ambiguous reference to field '" ++ member ++ "' in class '" ++ objectType ++ "'"
-                            _ -> error $ "Ambiguous reference to '" ++ member ++ "' in class '" ++ objectType ++ "'"
                       Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class"
-            _ -> error "Name resolution requires object reference and member name"
+              (TypedExpression t1 (Reference obj), StatementExpressionExpression (MethodCall methodName args)) ->
+                let objectType = lookupType obj symtab
+                in typeCheckExpression (checkMethod methodName args symtab classes objectType) symtab classes
+              _ -> error "Name resolution requires object reference and field name"
 
 typeCheckExpression (UnaryOperation op expr) symtab classes =
   let expr' = typeCheckExpression expr symtab classes
@@ -187,12 +190,54 @@ typeCheckStatementExpression (Assignment id expr) symtab classes =
           error "Assignment type mismatch"
 
 typeCheckStatementExpression (ConstructorCall className args) symtab classes =
-  let args' = map (\arg -> typeCheckExpression arg symtab classes) args
+  case find (\(Class name _ _) -> name == className) classes of
-   in TypedStatementExpression className (ConstructorCall className args')
+    Nothing -> error $ "Class '" ++ className ++ "' not found."
+    Just (Class _ methods fields) ->
+      -- Constructor needs the same name as the class
+      case find (\(MethodDeclaration retType name params _) -> name == className && retType == className) methods of
+        Nothing -> error $ "No valid constructor found for class '" ++ className ++ "'."
+        Just (MethodDeclaration _ _ params _) ->
+          let
+            args' = map (\arg -> typeCheckExpression arg symtab classes) args
+            -- Extract expected parameter types from the constructor's parameters
+            expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
+            argTypes = map getTypeFromExpr args'
+            -- Check if the types of the provided arguments match the expected types
+            typeMatches = zipWith (\expected actual -> if expected == actual then Nothing else Just (expected, actual)) expectedTypes argTypes
+            mismatchErrors = map (\(exp, act) -> "Expected type '" ++ exp ++ "', found '" ++ act ++ "'.") (catMaybes typeMatches)
+          in
+            if length args /= length params then
+              error $ "Constructor for class '" ++ className ++ "' expects " ++ show (length params) ++ " arguments, but got " ++ show (length args) ++ "."
+            else if not (null mismatchErrors) then
+              error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':") : mismatchErrors
+            else
+              TypedStatementExpression className (ConstructorCall className args')
 
 typeCheckStatementExpression (MethodCall methodName args) symtab classes =
-  let args' = map (\arg -> typeCheckExpression arg symtab classes) args
+  case lookup methodName symtab of
-   in TypedStatementExpression "Object" (MethodCall methodName args')
+    Just className ->
+      case find (\(Class name _ _) -> name == className) classes of
+        Just (Class _ methods _) ->
+          case find (\(MethodDeclaration retType name params _) -> name == methodName) methods of
+            Just (MethodDeclaration retType _ params _) ->
+              let
+                args' = map (\arg -> typeCheckExpression arg symtab classes) args
+                expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
+                argTypes = map getTypeFromExpr args'
+                typeMatches = zipWith (\expType argType -> (expType == argType, expType, argType)) expectedTypes argTypes
+                mismatches = filter (not . fst3) typeMatches
+                  where fst3 (a, _, _) = a
+             in
+                if null mismatches && length args == length params then
+                  TypedStatementExpression retType (MethodCall methodName args')
+                else if not (null mismatches) then
+                  error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
+                    : [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
+                else
+                  error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
+            Nothing -> error $ "Method '" ++ methodName ++ "' not found in class '" ++ className ++ "'."
+        Nothing -> error $ "Class '" ++ className ++ "' not found."
+    Nothing -> error $ "Method or class context for '" ++ methodName ++ "' not found in symbol table."
 
 -- ********************************** Type Checking: Statements **********************************
 
@@ -264,6 +309,10 @@ typeCheckStatement (Return expr) symtab classes =
         Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
         Nothing -> TypedStatement "Void" (Return Nothing)
 
+typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
+  let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
+   in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
+
 -- ********************************** Type Checking: Helpers **********************************
 
 getTypeFromExpr :: Expression -> DataType
@@ -288,3 +337,22 @@ lookupType id symtab =
   case lookup id symtab of
     Just t  -> t
     Nothing -> error ("Identifier " ++ id ++ " not found in symbol table")
+
+checkMethod :: Identifier -> [Expression] -> [(Identifier, DataType)] -> [Class] -> String -> Expression
+checkMethod methodName args symtab classes objectType =
+    case find (\(Class className _ _) -> className == objectType) classes of
+        Just (Class _ methods _) ->
+          case find (\(MethodDeclaration retType name params _) -> name == methodName) methods of
+            Just (MethodDeclaration retType _ params _) ->
+              let
+                args' = map (\arg -> typeCheckExpression arg symtab classes) args
+                expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
+                argTypes = map getTypeFromExpr args'
+                typeMatches = all (uncurry (==)) (zip expectedTypes argTypes)
+              in
+                if typeMatches && length args == length params then
+                   StatementExpressionExpression (TypedStatementExpression retType (MethodCall methodName args'))
+                else
+                  error $ "Argument type mismatch for method '" ++ methodName ++ "' or incorrect number of arguments provided."
+            Nothing -> error $ "Method '" ++ methodName ++ "' not found in class '" ++ objectType ++ "'."
+        Nothing -> error $ "Class '" ++ objectType ++ "' not found."