add typecheck method and constructor call
This commit is contained in:
Maybe Fabian Noll aber vielleicht auch nicht. Ist ein bisschen ne Glaubenssache :)
parent
7422510267
commit
358293d4d4
108
src/Typecheck.hs
108
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")
|
||||
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."
|
||||
Loading…
Reference in New Issue
Block a user