From 358293d4d4c6bcc59eca05a57957c90e8134155f Mon Sep 17 00:00:00 2001 From: MisterChaos96 Date: Tue, 7 May 2024 11:28:35 +0200 Subject: [PATCH] add typecheck method and constructor call --- src/Typecheck.hs | 108 ++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 88 insertions(+), 20 deletions(-) diff --git a/src/Typecheck.hs b/src/Typecheck.hs index 2794204..5b3eddf 100644 --- a/src/Typecheck.hs +++ b/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 @@ -136,21 +139,21 @@ typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes = error "Logical OR operation requires two operands of type boolean" NameResolution -> case (expr1', expr2) of - (TypedExpression t1 (Reference obj), Reference member) -> - -- Lookup the class type of obj from the symbol table + (TypedExpression t1 (Reference obj), Reference member) -> + let objectType = lookupType obj symtab + classDetails = find (\(Class className _ _) -> className == objectType) classes + in case classDetails of + Just (Class _ _ fields) -> + let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member] + in case fieldTypes of + [resolvedType] -> TypedExpression resolvedType (Reference member) + [] -> error $ "Field '" ++ member ++ "' not found in class '" ++ objectType ++ "'" + _ -> error $ "Ambiguous reference to field '" ++ member ++ "' in class '" ++ objectType ++ "'" + Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class" + (TypedExpression t1 (Reference obj), StatementExpressionExpression (MethodCall methodName args)) -> let objectType = lookupType obj symtab - classDetails = find (\(Class className _ _) -> className == objectType) classes - in case classDetails of - Just (Class _ methods 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 ++ methodTypes of - [resolvedType] -> TypedExpression resolvedType (BinaryOperation op expr1' (TypedExpression resolvedType (Reference member))) - [] -> error $ "Member '" ++ member ++ "' not found 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" + 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 - in TypedStatementExpression className (ConstructorCall className args') + case find (\(Class name _ _) -> name == className) classes of + 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 - in TypedStatementExpression "Object" (MethodCall methodName args') + case lookup methodName symtab of + 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 @@ -287,4 +336,23 @@ lookupType :: Identifier -> [(Identifier, DataType)] -> DataType lookupType id symtab = case lookup id symtab of Just t -> t - Nothing -> error ("Identifier " ++ id ++ " not found in symbol table") \ No newline at end of file + 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." \ No newline at end of file