Merge remote-tracking branch 'origin/typedAST' into create-parser

2024-05-14 11:28:15 +02:00 · 2024-05-14 11:28:15 +02:00 · 83e6964d71
commit 83e6964d71
parent 64829c2086 f8b0b59c5d
3 changed files with 175 additions and 131 deletions
--- a/src/Ast.hs
+++ b/src/Ast.hs
@ -20,7 +20,7 @@ data Statement
  deriving (Show, Eq)

 data StatementExpression
-  = Assignment Identifier Expression
+  = Assignment Expression Expression
  | ConstructorCall DataType [Expression]
  | MethodCall Expression Identifier [Expression]
  | TypedStatementExpression DataType StatementExpression
@ -49,6 +49,10 @@ data BinaryOperator
 data UnaryOperator
  = Not
  | Minus
+  | PostIncrement
+  | PostDecrement
+  | PreIncrement
+  | PreDecrement
  deriving (Show, Eq)

 data Expression
--- a/src/Example.hs
+++ b/src/Example.hs
@ -49,7 +49,7 @@ exampleExpression :: Expression
 exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")

 exampleAssignment :: Expression
-exampleAssignment = StatementExpressionExpression (Assignment "a" (IntegerLiteral 30))
+exampleAssignment = StatementExpressionExpression (Assignment (Reference "a") (IntegerLiteral 30))

 exampleMethodCall :: Statement
 exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
@ -58,7 +58,7 @@ exampleConstructorCall :: Statement
 exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression  (ConstructorCall "Person" [IntegerLiteral 30]))))

 exampleNameResolution :: Expression
-exampleNameResolution = BinaryOperation NameResolution (Reference "b") (Reference "age")
+exampleNameResolution = BinaryOperation NameResolution (Reference "bob2") (Reference "age")

 exampleBlockResolution :: Statement
 exampleBlockResolution = Block [
@ -80,7 +80,7 @@ exampleMethodCallAndAssignment = Block [
    LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
    StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
    LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
-    StatementExpressionStatement (Assignment "a" (Reference "age"))
+    StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
    ]


@ -89,9 +89,18 @@ exampleMethodCallAndAssignmentFail = Block [
    LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression  (ConstructorCall "Person" [IntegerLiteral 30])))),
    LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
    StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
-    StatementExpressionStatement (Assignment "a" (Reference "age"))
+    StatementExpressionStatement (Assignment (Reference "a") (Reference "age"))
    ]

+exampleNameResolutionAssignment :: Statement
+exampleNameResolutionAssignment = Block [
+    LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression  (ConstructorCall "Person" [IntegerLiteral 30])))),
+    StatementExpressionStatement (Assignment (BinaryOperation NameResolution (Reference "bob") (Reference "age")) (IntegerLiteral 30))
+    ]
+
+exampleCharIntOperation :: Expression
+exampleCharIntOperation = BinaryOperation Addition (CharacterLiteral 'a') (IntegerLiteral 1)
+
 testClasses :: [Class]
 testClasses = [
    Class "Person" [
@ -113,10 +122,12 @@ testClasses = [
        (Block [
            LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
            StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
-            LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
+            LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob2") "getAge" [])))),
            Return (Just (Reference "bobAge"))
        ])
-    ] []
+    ] [
+        VariableDeclaration "Person" "bob2" Nothing
+    ]
 ]

 runTypeCheck :: IO ()
@ -151,7 +162,7 @@ runTypeCheck = do

    catch (do
        print "====================================================================================="
-        evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("b", "Person")] sampleClasses)
+        evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("this", "Main")] testClasses)
        printSuccess "Type checking of name resolution completed successfully"
        printResult "Result Name Resolution:" evaluatedNameResolution
      ) handleError
@ -189,7 +200,7 @@ runTypeCheck = do
        let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
        case mainClass of
            Class _ [mainMethod] _ -> do
-                let result = typeCheckMethodDeclaration mainMethod [] testClasses
+                let result = typeCheckMethodDeclaration mainMethod [("this", "Main")] testClasses
                printSuccess "Full program type checking completed successfully."
                printResult "Main method result:" result
      ) handleError
@ -200,4 +211,18 @@ runTypeCheck = do
        printSuccess "Type checking of Program completed successfully"
        printResult "Typed Program:" typedProgram
        ) handleError
+    
+    catch (do
+        print "====================================================================================="
+        typedAssignment <- evaluate (typeCheckStatement exampleNameResolutionAssignment [] sampleClasses)
+        printSuccess "Type checking of name resolution assignment completed successfully"
+        printResult "Result Name Resolution Assignment:" typedAssignment
+        ) handleError
+
+    catch (do
+        print "====================================================================================="
+        evaluatedCharIntOperation <- evaluate (typeCheckExpression exampleCharIntOperation [] sampleClasses)
+        printSuccess "Type checking of char int operation completed successfully"
+        printResult "Result Char Int Operation:" evaluatedCharIntOperation
+        ) handleError

--- a/src/Typecheck.hs
+++ b/src/Typecheck.hs
@ -10,9 +10,9 @@ typeCheckClass :: Class -> [Class] -> Class
 typeCheckClass (Class className methods fields) classes =
    let
        -- Create a symbol table from class fields and method entries
-        classFields = [(id, dt) | VariableDeclaration dt id _ <- fields]
+        -- TODO: Maybe remove method entries from the symbol table?
        methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
-        initalSymTab = ("this", className) : classFields ++ methodEntries
+        initalSymTab = ("this", className) : methodEntries
        checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
    in Class className checkedMethods fields

@ -37,118 +37,46 @@ typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (Character
 typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
 typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
 typeCheckExpression (Reference id) symtab classes =
-  let type' = lookupType id symtab
-   in TypedExpression type' (Reference id)
+  case lookup id symtab of
+    Just t -> TypedExpression t (LocalVariable id)
+    Nothing ->
+      case lookup "this" symtab of
+        Just className ->
+          let classDetails = find (\(Class name _ _) -> name == className) classes
+          in case classDetails of
+            Just (Class _ _ fields) ->
+              let fieldTypes = [dt | VariableDeclaration dt fieldId _ <- fields, fieldId == id]
+              in case fieldTypes of
+                [fieldType] -> TypedExpression fieldType (FieldVariable id)
+                [] -> error $ "Field '" ++ id ++ "' not found in class '" ++ className ++ "'"
+                _ -> error $ "Ambiguous reference to field '" ++ id ++ "' in class '" ++ className ++ "'"
+            Nothing -> error $ "Class '" ++ className ++ "' not found for 'this'"
+        Nothing -> error $ "Context for 'this' not found in symbol table, unable to resolve '" ++ id ++ "'"
+
 typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
  let expr1' = typeCheckExpression expr1 symtab classes
      expr2' = typeCheckExpression expr2 symtab classes
      type1 = getTypeFromExpr expr1'
      type2 = getTypeFromExpr expr2'
+      resultType = resolveResultType type1 type2
   in case op of
-        Addition ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Addition operation requires two operands of type int"
-        Subtraction ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Subtraction operation requires two operands of type int"
-        Multiplication ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Multiplication operation requires two operands of type int"
-        Division ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Division operation requires two operands of type int"
-        BitwiseAnd ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Bitwise AND operation requires two operands of type int"
-        BitwiseOr ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Bitwise OR operation requires two operands of type int"
-        BitwiseXor ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "int" (BinaryOperation op expr1' expr2')
-            else
-              error "Bitwise XOR operation requires two operands of type int"
-        CompareLessThan ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Less than operation requires two operands of type int"
-        CompareLessOrEqual ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Less than or equal operation requires two operands of type int"
-        CompareGreaterThan ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Greater than operation requires two operands of type int"
-        CompareGreaterOrEqual ->
-          if type1 == "int" && type2 == "int"
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Greater than or equal operation requires two operands of type int"
-        CompareEqual ->
-          if type1 == type2
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Equality operation requires two operands of the same type"
-        CompareNotEqual ->
-          if type1 == type2
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Inequality operation requires two operands of the same type"
-        And ->
-          if type1 == "boolean" && type2 == "boolean"
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Logical AND operation requires two operands of type boolean"
-        Or ->
-          if type1 == "boolean" && type2 == "boolean"
-            then
-              TypedExpression "boolean" (BinaryOperation op expr1' expr2')
-            else
-              error "Logical OR operation requires two operands of type boolean"
-        NameResolution ->
-          case (expr1', expr2) of
-              (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 (BinaryOperation NameResolution expr1' (TypedExpression resolvedType expr2))
-                              [] -> 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"
-              _ -> error "Name resolution requires object reference and field name"
+        Addition -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
+        Subtraction -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
+        Multiplication -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
+        Division -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
+        Modulo -> checkArithmeticOperation op expr1' expr2' type1 type2 resultType
+        BitwiseAnd -> checkBitwiseOperation op expr1' expr2' type1 type2
+        BitwiseOr -> checkBitwiseOperation op expr1' expr2' type1 type2
+        BitwiseXor -> checkBitwiseOperation op expr1' expr2' type1 type2
+        CompareLessThan -> checkComparisonOperation op expr1' expr2' type1 type2
+        CompareLessOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
+        CompareGreaterThan -> checkComparisonOperation op expr1' expr2' type1 type2
+        CompareGreaterOrEqual -> checkComparisonOperation op expr1' expr2' type1 type2
+        CompareEqual -> checkEqualityOperation op expr1' expr2' type1 type2
+        CompareNotEqual -> checkEqualityOperation op expr1' expr2' type1 type2
+        And -> checkLogicalOperation op expr1' expr2' type1 type2
+        Or -> checkLogicalOperation op expr1' expr2' type1 type2
+        NameResolution -> resolveNameResolution expr1' expr2 symtab classes

 typeCheckExpression (UnaryOperation op expr) symtab classes =
  let expr' = typeCheckExpression expr symtab classes
@ -164,8 +92,47 @@ typeCheckExpression (UnaryOperation op expr) symtab classes =
          if type' == "int"
            then
              TypedExpression "int" (UnaryOperation op expr')
+          else if type' == "char"
+            then
+              TypedExpression "char" (UnaryOperation op expr')
            else
-              error "Unary minus operation requires an operand of type int"
+              error "Unary minus operation requires an operand of type int or char"
+        PostIncrement ->
+          if type' == "int"
+            then
+              TypedExpression "int" (UnaryOperation op expr')
+          else if type' == "char"
+            then
+              TypedExpression "char" (UnaryOperation op expr')
+            else
+              error "Post-increment operation requires an operand of type int or char"
+        PostDecrement ->
+          if type' == "int"
+            then
+              TypedExpression "int" (UnaryOperation op expr')
+          else if type' == "char"
+            then
+              TypedExpression "char" (UnaryOperation op expr')
+            else
+              error "Post-decrement operation requires an operand of type int or char"
+        PreIncrement ->
+          if type' == "int"
+            then
+              TypedExpression "int" (UnaryOperation op expr')
+          else if type' == "char"
+            then
+              TypedExpression "char" (UnaryOperation op expr')
+            else
+              error "Pre-increment operation requires an operand of type int or char"
+        PreDecrement ->
+          if type' == "int"
+            then
+              TypedExpression "int" (UnaryOperation op expr')
+          else if type' == "char"
+            then
+              TypedExpression "char" (UnaryOperation op expr')
+            else
+              error "Pre-decrement operation requires an operand of type int or char"

 typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
  let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
@ -174,15 +141,16 @@ typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
 -- ********************************** Type Checking: StatementExpressions **********************************

 typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
-typeCheckStatementExpression (Assignment id expr) symtab classes =
+typeCheckStatementExpression (Assignment ref expr) symtab classes =
  let expr' = typeCheckExpression expr symtab classes
+      ref' = typeCheckExpression ref symtab classes
      type' = getTypeFromExpr expr'
-      type'' = lookupType id symtab
-   in if type' == type''
-        then
-          TypedStatementExpression type' (Assignment id expr')
-        else
-          error "Assignment type mismatch"
+      type'' = getTypeFromExpr ref'
+    in
+      if type'' == type' then
+        TypedStatementExpression type' (Assignment ref' expr')
+      else
+        error $ "Type mismatch in assignment to variable: expected " ++ type'' ++ ", found " ++ type'

 typeCheckStatementExpression (ConstructorCall className args) symtab classes =
  case find (\(Class name _ _) -> name == className) classes of
@ -302,7 +270,7 @@ typeCheckStatement (Return expr) symtab classes =
        Nothing -> Nothing
   in case expr' of
        Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
-        Nothing -> TypedStatement "Void" (Return Nothing)
+        Nothing -> TypedStatement "void" (Return Nothing)

 typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
  let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
@ -327,8 +295,55 @@ unifyReturnTypes dt1 dt2
    | dt1 == dt2 = dt1
    | otherwise  = "Object"

-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")
+resolveResultType :: DataType -> DataType -> DataType
+resolveResultType "char" "char" = "char"
+resolveResultType "int" "int" = "int"
+resolveResultType "char" "int" = "int"
+resolveResultType "int" "char" = "int"
+resolveResultType t1 t2
+  | t1 == t2 = t1
+  | otherwise = error $ "Incompatible types: " ++ t1 ++ " and " ++ t2
+
+checkArithmeticOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> DataType -> Expression
+checkArithmeticOperation op expr1' expr2' type1 type2 resultType
+  | (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") =
+      TypedExpression resultType (BinaryOperation op expr1' expr2')
+  | otherwise = error $ "Arithmetic operation " ++ show op ++ " requires operands of type int or char"
+
+checkBitwiseOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
+checkBitwiseOperation op expr1' expr2' type1 type2
+  | type1 == "int" && type2 == "int" =
+      TypedExpression "int" (BinaryOperation op expr1' expr2')
+  | otherwise = error $ "Bitwise operation " ++ show op ++ " requires operands of type int"
+
+checkComparisonOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
+checkComparisonOperation op expr1' expr2' type1 type2
+  | (type1 == "int" || type1 == "char") && (type2 == "int" || type2 == "char") =
+      TypedExpression "boolean" (BinaryOperation op expr1' expr2')
+  | otherwise = error $ "Comparison operation " ++ show op ++ " requires operands of type int or char"
+
+checkEqualityOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
+checkEqualityOperation op expr1' expr2' type1 type2
+  | type1 == type2 =
+      TypedExpression "boolean" (BinaryOperation op expr1' expr2')
+  | otherwise = error $ "Equality operation " ++ show op ++ " requires operands of the same type"
+
+checkLogicalOperation :: BinaryOperator -> Expression -> Expression -> DataType -> DataType -> Expression
+checkLogicalOperation op expr1' expr2' type1 type2
+  | type1 == "boolean" && type2 == "boolean" =
+      TypedExpression "boolean" (BinaryOperation op expr1' expr2')
+  | otherwise = error $ "Logical operation " ++ show op ++ " requires operands of type boolean"
+
+resolveNameResolution :: Expression -> Expression -> [(Identifier, DataType)] -> [Class] -> Expression
+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)))
+            [] -> 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"