add public private to typecheck
This commit is contained in:
Maybe Fabian Noll aber vielleicht auch nicht. Ist ein bisschen ne Glaubenssache :)
parent
53061fb73d
commit
ab7077d8f0
140
src/Typecheck.hs
140
src/Typecheck.hs
@ -1,19 +1,19 @@
|
||||
module Typecheck where
|
||||
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Ast
|
||||
|
||||
|
||||
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
|
||||
typeCheckCompilationUnit classes =
|
||||
let
|
||||
-- Helper function to add a default constructor if none are present
|
||||
ensureDefaultConstructor :: Class -> Class
|
||||
ensureDefaultConstructor (Class className constructors methods fields) =
|
||||
ensureDefaultConstructor (Class className modifier constructors methods fields) =
|
||||
let
|
||||
defaultConstructor = ConstructorDeclaration className [] (Block [])
|
||||
defaultConstructor = ConstructorDeclaration modifier className [] (Block [])
|
||||
constructorsWithDefault = if null constructors then [defaultConstructor] else constructors
|
||||
in Class className constructorsWithDefault methods fields
|
||||
in Class className modifier constructorsWithDefault methods fields
|
||||
|
||||
-- Inject default constructors into all classes
|
||||
classesWithDefaultConstructors = map ensureDefaultConstructor classes
|
||||
@ -21,7 +21,7 @@ typeCheckCompilationUnit classes =
|
||||
in map (`typeCheckClass` classesWithDefaultConstructors) classesWithDefaultConstructors
|
||||
|
||||
typeCheckClass :: Class -> [Class] -> Class
|
||||
typeCheckClass (Class className constructors methods fields) classes =
|
||||
typeCheckClass (Class className modifier constructors methods fields) classes =
|
||||
let
|
||||
-- Fields and methods dont need to be added to the symtab because they are looked upon automatically under "this"
|
||||
-- if its not a declared local variable. Also shadowing wouldnt be possible then.
|
||||
@ -29,10 +29,10 @@ typeCheckClass (Class className constructors methods fields) classes =
|
||||
checkedConstructors = map (\constructor -> typeCheckConstructorDeclaration constructor initalSymTab classes) constructors
|
||||
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
|
||||
checkedFields = map (\field -> typeCheckVariableDeclaration field initalSymTab classes) fields
|
||||
in Class className checkedConstructors checkedMethods checkedFields
|
||||
in Class className modifier checkedConstructors checkedMethods checkedFields
|
||||
|
||||
typeCheckConstructorDeclaration :: ConstructorDeclaration -> [(Identifier, DataType)] -> [Class] -> ConstructorDeclaration
|
||||
typeCheckConstructorDeclaration (ConstructorDeclaration name params body) symtab classes =
|
||||
typeCheckConstructorDeclaration (ConstructorDeclaration modifier name params body) symtab classes =
|
||||
let
|
||||
constructorParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
initialSymtab = symtab ++ constructorParams
|
||||
@ -41,24 +41,23 @@ typeCheckConstructorDeclaration (ConstructorDeclaration name params body) symtab
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
in if name == className
|
||||
then if bodyType == "void"
|
||||
then ConstructorDeclaration name params checkedBody
|
||||
then ConstructorDeclaration modifier name params checkedBody
|
||||
else error $ "Constructor Declaration: Return type mismatch in constructor " ++ name ++ ": expected void, found " ++ bodyType
|
||||
else error $ "Constructor Declaration: Constructor name " ++ name ++ " does not match class name " ++ className
|
||||
|
||||
|
||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||
typeCheckMethodDeclaration (MethodDeclaration retType name params body) symtab classes =
|
||||
typeCheckMethodDeclaration (MethodDeclaration retType modifier name params body) symtab classes =
|
||||
let
|
||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
initialSymtab = ("thisMeth", retType) : symtab ++ methodParams
|
||||
checkedBody = typeCheckStatement body initialSymtab classes
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
in if bodyType == retType || (bodyType == "void" && retType == "void") || (bodyType == "null" && isObjectType retType) || isSubtype bodyType retType classes
|
||||
then MethodDeclaration retType name params checkedBody
|
||||
then MethodDeclaration retType modifier name params checkedBody
|
||||
else error $ "Method Declaration: Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||
|
||||
typeCheckVariableDeclaration :: VariableDeclaration -> [(Identifier, DataType)] -> [Class] -> VariableDeclaration
|
||||
typeCheckVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) symtab classes =
|
||||
typeCheckVariableDeclaration (VariableDeclaration dataType modifier identifier maybeExpr) symtab classes =
|
||||
let
|
||||
-- Ensure the type is valid (either a primitive type or a valid class name)
|
||||
validType = dataType `elem` ["int", "boolean", "char"] || isUserDefinedClass dataType classes
|
||||
@ -74,11 +73,10 @@ typeCheckVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)
|
||||
(False, _, _) -> error $ "Type '" ++ dataType ++ "' is not a valid type for variable '" ++ identifier ++ "'"
|
||||
(_, True, _) -> error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
|
||||
(_, _, Just t)
|
||||
| t == "null" && isObjectType dataType -> VariableDeclaration dataType identifier checkedExprWithType
|
||||
| t == "null" && isObjectType dataType -> VariableDeclaration dataType modifier identifier checkedExprWithType
|
||||
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
| otherwise -> VariableDeclaration dataType identifier checkedExprWithType
|
||||
(_, _, Nothing) -> VariableDeclaration dataType identifier checkedExprWithType
|
||||
|
||||
| otherwise -> VariableDeclaration dataType modifier identifier checkedExprWithType
|
||||
(_, _, Nothing) -> VariableDeclaration dataType modifier identifier checkedExprWithType
|
||||
|
||||
-- ********************************** Type Checking: Expressions **********************************
|
||||
|
||||
@ -93,10 +91,10 @@ typeCheckExpression (Reference id) symtab classes =
|
||||
Nothing ->
|
||||
case lookup "this" symtab of
|
||||
Just className ->
|
||||
let classDetails = find (\(Class name _ _ _) -> name == className) classes
|
||||
let classDetails = find (\(Class name _ _ _ _) -> name == className) classes
|
||||
in case classDetails of
|
||||
Just (Class _ _ _ fields) ->
|
||||
let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
|
||||
Just (Class _ _ _ _ fields) ->
|
||||
let fieldTypes = [dt | VariableDeclaration dt modifier fieldId _ <- fields, fieldId == id]
|
||||
-- this case only happens when its a field of its own class so the implicit this will be converted to explicit this
|
||||
in case fieldTypes of
|
||||
[fieldType] -> TypedExpression fieldType (BinaryOperation NameResolution (TypedExpression className (LocalVariable "this")) (TypedExpression fieldType (FieldVariable id)))
|
||||
@ -167,35 +165,36 @@ typeCheckStatementExpression (Assignment ref expr) symtab classes =
|
||||
else
|
||||
error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ typeToAssign
|
||||
|
||||
|
||||
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
||||
case find (\(Class name _ _ _) -> name == className) classes of
|
||||
case find (\(Class name _ _ _ _) -> name == className) classes of
|
||||
Nothing -> error $ "Class '" ++ className ++ "' not found."
|
||||
Just (Class _ constructors _ _) ->
|
||||
let
|
||||
matchParams (ParameterDeclaration paramType _) arg =
|
||||
let argTyped = typeCheckExpression arg symtab classes
|
||||
argType = getTypeFromExpr argTyped
|
||||
in if argType == "null" && isObjectType paramType
|
||||
then Just (TypedExpression paramType NullLiteral)
|
||||
else if argType == paramType
|
||||
then Just argTyped
|
||||
else Nothing
|
||||
Just (Class _ modifier constructors _ _) ->
|
||||
let matchParams (ParameterDeclaration paramType _) arg =
|
||||
let argTyped = typeCheckExpression arg symtab classes
|
||||
argType = getTypeFromExpr argTyped
|
||||
in if argType == "null" && isObjectType paramType
|
||||
then Just (TypedExpression paramType NullLiteral)
|
||||
else if argType == paramType
|
||||
then Just argTyped
|
||||
else Nothing
|
||||
|
||||
matchConstructor (ConstructorDeclaration name params _) =
|
||||
let matchedArgs = sequence $ zipWith matchParams params args
|
||||
in fmap (\checkedArgs -> (params, checkedArgs)) matchedArgs
|
||||
matchConstructor (ConstructorDeclaration constructorModifier name params _)
|
||||
| constructorModifier == "public" = fmap (\checkedArgs -> (ConstructorDeclaration constructorModifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
| constructorModifier == "private" = if checkAccess className (lookup "this" symtab)
|
||||
then fmap (\checkedArgs -> (ConstructorDeclaration constructorModifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
else Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
validConstructors = filter (\(params, _) -> length params == length args) $ mapMaybe matchConstructor constructors
|
||||
validConstructors = filter (\(ConstructorDeclaration _ _ params _, _) -> length params == length args) $ mapMaybe matchConstructor constructors
|
||||
|
||||
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | ConstructorDeclaration _ params _ <- constructors ]
|
||||
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args
|
||||
mismatchDetails = "Constructor not found for class '" ++ className ++ "' with given arguments.\n" ++
|
||||
"Expected signatures:\n" ++ show expectedSignatures ++
|
||||
"\nActual arguments:" ++ show actualSignature
|
||||
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | ConstructorDeclaration _ _ params _ <- constructors ]
|
||||
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args
|
||||
mismatchDetails = "Constructor not found for class '" ++ className ++ "' with given arguments.\n" ++
|
||||
"Expected signatures:\n" ++ show expectedSignatures ++
|
||||
"\nActual arguments:" ++ show actualSignature
|
||||
|
||||
in case validConstructors of
|
||||
[(_, checkedArgs)] ->
|
||||
[(ConstructorDeclaration _ _ params _, checkedArgs)] ->
|
||||
TypedStatementExpression className (ConstructorCall className checkedArgs)
|
||||
[] -> error mismatchDetails
|
||||
_ -> error $ "Multiple matching constructors found for class '" ++ className ++ "' with given arguments."
|
||||
@ -204,8 +203,8 @@ typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
||||
let objExprTyped = typeCheckExpression expr symtab classes
|
||||
in case objExprTyped of
|
||||
TypedExpression objType _ ->
|
||||
case find (\(Class className _ _ _) -> className == objType) classes of
|
||||
Just (Class _ _ methods _) ->
|
||||
case find (\(Class className _ _ _ _) -> className == objType) classes of
|
||||
Just (Class className _ _ methods _) ->
|
||||
let matchParams (ParameterDeclaration paramType _) arg =
|
||||
let argTyped = typeCheckExpression arg symtab classes
|
||||
argType = getTypeFromExpr argTyped
|
||||
@ -215,27 +214,31 @@ typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
||||
then Just argTyped
|
||||
else Nothing
|
||||
|
||||
matchMethod (MethodDeclaration retType name params _) =
|
||||
let matchedArgs = sequence $ zipWith matchParams params args
|
||||
in fmap (\checkedArgs -> (MethodDeclaration retType name params (Block []), checkedArgs)) matchedArgs
|
||||
matchMethod (MethodDeclaration retType modifier name params _)
|
||||
| modifier == "public" = fmap (\checkedArgs -> (MethodDeclaration retType modifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
| modifier == "private" = if checkAccess className (lookup "this" symtab)
|
||||
then fmap (\checkedArgs -> (MethodDeclaration retType modifier name params (Block []), checkedArgs)) (sequence $ zipWith matchParams params args)
|
||||
else Nothing
|
||||
| otherwise = Nothing
|
||||
|
||||
validMethods = filter (\(MethodDeclaration _ name params _, _) -> name == methodName && length params == length args) $ mapMaybe matchMethod methods
|
||||
validMethods = filter (\(MethodDeclaration _ _ name params _, _) -> name == methodName && length params == length args) $ mapMaybe matchMethod methods
|
||||
|
||||
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | MethodDeclaration _ name params _ <- methods, name == methodName ]
|
||||
expectedSignatures = [ map (\(ParameterDeclaration t _) -> t) params | MethodDeclaration _ _ name params _ <- methods, name == methodName ]
|
||||
actualSignature = map (\arg -> getTypeFromExpr (typeCheckExpression arg symtab classes)) args
|
||||
mismatchDetails = "Method not found for class '" ++ objType ++ "' with given arguments.\n" ++
|
||||
"Expected signatures for method '" ++ methodName ++ "':\n" ++ unlines (map show expectedSignatures) ++
|
||||
"Actual arguments:\n" ++ show actualSignature
|
||||
|
||||
in case validMethods of
|
||||
[(MethodDeclaration retType _ params _, checkedArgs)] ->
|
||||
[(MethodDeclaration retType _ _ params _, checkedArgs)] ->
|
||||
TypedStatementExpression retType (MethodCall objExprTyped methodName checkedArgs)
|
||||
[] -> error mismatchDetails
|
||||
_ -> error $ "Multiple matching methods found for class '" ++ objType ++ "' and method '" ++ methodName ++ "' with given arguments."
|
||||
|
||||
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
|
||||
_ -> error "Invalid object type for method call. Object must have a class type."
|
||||
|
||||
|
||||
|
||||
typeCheckStatementExpression (PostIncrement expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
@ -292,8 +295,7 @@ typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
||||
then TypedStatement ifType (If cond' thenStmt' elseStmt')
|
||||
else error "If condition must be of type boolean"
|
||||
|
||||
|
||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
|
||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier maybeExpr)) symtab classes =
|
||||
-- Check for redefinition in the current scope
|
||||
if any ((== identifier) . snd) symtab
|
||||
then error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
|
||||
@ -307,11 +309,10 @@ typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType ident
|
||||
in case exprType of
|
||||
Just t
|
||||
| t == "null" && isObjectType dataType ->
|
||||
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType))
|
||||
TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier checkedExprWithType))
|
||||
| t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExprWithType))
|
||||
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
|
||||
| otherwise -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier checkedExprWithType))
|
||||
Nothing -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType modifier identifier checkedExpr))
|
||||
|
||||
typeCheckStatement (While cond stmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
@ -326,7 +327,7 @@ typeCheckStatement (Block statements) symtab classes =
|
||||
let
|
||||
processStatements (accSts, currentSymtab, types) stmt =
|
||||
case stmt of
|
||||
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
||||
LocalVariableDeclaration (VariableDeclaration dataType modifier identifier maybeExpr) ->
|
||||
let
|
||||
alreadyDefined = any (\(id, _) -> id == identifier) currentSymtab
|
||||
newSymtab = if alreadyDefined
|
||||
@ -355,7 +356,6 @@ typeCheckStatement (Block statements) symtab classes =
|
||||
|
||||
in TypedStatement blockType (Block checkedStatements)
|
||||
|
||||
|
||||
typeCheckStatement (Return expr) symtab classes =
|
||||
let methodReturnType = fromMaybe (error "Method return type not found in symbol table") (lookup "thisMeth" symtab)
|
||||
expr' = case expr of
|
||||
@ -369,7 +369,6 @@ typeCheckStatement (Return expr) symtab classes =
|
||||
then TypedStatement returnType (Return expr')
|
||||
else error $ "Return: Return type mismatch: expected " ++ methodReturnType ++ ", found " ++ returnType
|
||||
|
||||
|
||||
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
|
||||
@ -385,7 +384,7 @@ isSubtype subType superType classes
|
||||
| otherwise = False
|
||||
|
||||
isUserDefinedClass :: DataType -> [Class] -> Bool
|
||||
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _ _) -> name) classes
|
||||
isUserDefinedClass dt classes = dt `elem` map (\(Class name _ _ _ _) -> name) classes
|
||||
|
||||
isObjectType :: DataType -> Bool
|
||||
isObjectType dt = dt /= "int" && dt /= "boolean" && dt /= "char"
|
||||
@ -446,7 +445,6 @@ checkEqualityOperation op expr1' expr2' type1 type2
|
||||
error $ "Equality operation " ++ show op ++ " requires that null can only be compared with object types. Found types: " ++ type1 ++ " and " ++ type2
|
||||
| otherwise = error $ "Equality operation " ++ show op ++ " encountered unexpected types: " ++ type1 ++ " and " ++ type2
|
||||
|
||||
|
||||
checkLogicalOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
|
||||
checkLogicalOperation op expr1' expr2' type1 type2
|
||||
| type1 == "boolean" && type2 == "boolean" =
|
||||
@ -457,12 +455,22 @@ resolveNameResolution :: Expression -> Expression -> [(Identifier, DataType)] ->
|
||||
resolveNameResolution expr1' (Reference ident2) symtab classes =
|
||||
case getTypeFromExpr expr1' of
|
||||
objType ->
|
||||
case find (\(Class className _ _ _) -> className == objType) classes of
|
||||
Just (Class _ _ _ fields) ->
|
||||
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == ident2]
|
||||
in case fieldTypes of
|
||||
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))
|
||||
case find (\(Class className _ _ _ _) -> className == objType) classes of
|
||||
Just (Class _ _ _ _ fields) ->
|
||||
let fieldDetails = [(dt, mod) | VariableDeclaration dt mod id _ <- fields, id == ident2]
|
||||
className = objType
|
||||
in case fieldDetails of
|
||||
[(resolvedType, mod)] ->
|
||||
if mod == "public" || (mod == "private" && checkAccess objType (lookup "this" symtab))
|
||||
then TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType (FieldVariable ident2)))
|
||||
else error $ "Field '" ++ ident2 ++ "' is private and cannot be accessed outside its class."
|
||||
[] -> error $ "Field '" ++ ident2 ++ "' not found in class '" ++ objType ++ "'"
|
||||
_ -> error $ "Ambiguous reference to field '" ++ ident2 ++ "' in class '" ++ objType ++ "'"
|
||||
Nothing -> error $ "Class '" ++ objType ++ "' not found"
|
||||
resolveNameResolution _ _ _ _ = error "Name resolution requires object reference and field name"
|
||||
|
||||
|
||||
checkAccess :: DataType -> Maybe DataType -> Bool
|
||||
checkAccess objType (Just thisClass) = objType == thisClass
|
||||
checkAccess _ Nothing = False
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user