moved type check to its own file
This commit is contained in:
mrab
parent
75272498c4
commit
ff03be2671
@ -12,7 +12,7 @@ executable compiler
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: src
|
||||
build-tool-depends: alex:alex, happy:happy
|
||||
other-modules: Parser.Lexer, Ast, Example
|
||||
other-modules: Parser.Lexer, Ast, Example, Typecheck
|
||||
|
||||
test-suite tests
|
||||
type: exitcode-stdio-1.0
|
||||
|
||||
294
src/Ast.hs
294
src/Ast.hs
@ -1,19 +1,12 @@
|
||||
module Ast where
|
||||
|
||||
import Data.List (find)
|
||||
|
||||
type CompilationUnit = [Class]
|
||||
|
||||
type DataType = String
|
||||
|
||||
type Identifier = String
|
||||
|
||||
data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show)
|
||||
|
||||
data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show)
|
||||
|
||||
data Class = Class DataType [MethodDeclaration] [VariableDeclaration] deriving (Show)
|
||||
|
||||
data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement deriving (Show)
|
||||
|
||||
data Statement
|
||||
@ -68,290 +61,3 @@ data Expression
|
||||
| StatementExpressionExpression StatementExpression
|
||||
| TypedExpression DataType Expression
|
||||
deriving (Show)
|
||||
|
||||
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
|
||||
typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
|
||||
|
||||
typeCheckClass :: Class -> [Class] -> Class
|
||||
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
|
||||
in Class className checkedMethods fields
|
||||
|
||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
|
||||
let
|
||||
-- Combine class fields with method parameters to form the initial symbol table for the method
|
||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
-- Ensure method parameters shadow class fields if names collide
|
||||
initialSymtab = classFields ++ methodParams
|
||||
-- Type check the body of the method using the combined symbol table
|
||||
checkedBody = typeCheckStatement body initialSymtab classes
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
-- Check if the type of the body matches the declared return type
|
||||
in if bodyType == retType || (bodyType == "void" && retType == "void")
|
||||
then MethodDeclaration retType name params checkedBody
|
||||
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||
|
||||
-- ********************************** Type Checking: Expressions **********************************
|
||||
|
||||
typeCheckExpression :: Expression -> [(Identifier, DataType)] -> [Class] -> Expression
|
||||
typeCheckExpression (IntegerLiteral i) _ _ = TypedExpression "int" (IntegerLiteral i)
|
||||
typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (CharacterLiteral c)
|
||||
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)
|
||||
typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
|
||||
let expr1' = typeCheckExpression expr1 symtab classes
|
||||
expr2' = typeCheckExpression expr2 symtab classes
|
||||
type1 = getTypeFromExpr expr1'
|
||||
type2 = getTypeFromExpr expr2'
|
||||
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) ->
|
||||
-- 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) ->
|
||||
-- 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"
|
||||
|
||||
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
in case op of
|
||||
Not ->
|
||||
if type' == "boolean"
|
||||
then
|
||||
TypedExpression "boolean" (UnaryOperation op expr')
|
||||
else
|
||||
error "Logical NOT operation requires an operand of type boolean"
|
||||
Minus ->
|
||||
if type' == "int"
|
||||
then
|
||||
TypedExpression "int" (UnaryOperation op expr')
|
||||
else
|
||||
error "Unary minus operation requires an operand of type int"
|
||||
|
||||
typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedExpression (getTypeFromStmtExpr stmtExpr') (StatementExpressionExpression stmtExpr')
|
||||
|
||||
-- ********************************** Type Checking: StatementExpressions **********************************
|
||||
-- TODO: Implement type checking for StatementExpressions
|
||||
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
||||
typeCheckStatementExpression (Assignment id expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
type'' = lookupType id symtab
|
||||
in if type' == type''
|
||||
then
|
||||
TypedStatementExpression type' (Assignment id expr')
|
||||
else
|
||||
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')
|
||||
|
||||
typeCheckStatementExpression (MethodCall methodName args) symtab classes =
|
||||
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
in TypedStatementExpression "Object" (MethodCall methodName args')
|
||||
|
||||
-- ********************************** Type Checking: Statements **********************************
|
||||
|
||||
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
|
||||
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
thenStmt' = typeCheckStatement thenStmt symtab classes
|
||||
elseStmt' = case elseStmt of
|
||||
Just stmt -> Just (typeCheckStatement stmt symtab classes)
|
||||
Nothing -> Nothing
|
||||
in if getTypeFromExpr cond' == "boolean"
|
||||
then
|
||||
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
|
||||
else
|
||||
error "If condition must be of type boolean"
|
||||
|
||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType 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"
|
||||
else
|
||||
-- If there's an initializer expression, type check it
|
||||
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||
exprType = fmap getTypeFromExpr checkedExpr
|
||||
in case exprType of
|
||||
Just t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
_ -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
|
||||
typeCheckStatement (While cond stmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
stmt' = typeCheckStatement stmt symtab classes
|
||||
in if getTypeFromExpr cond' == "boolean"
|
||||
then
|
||||
TypedStatement (getTypeFromStmt stmt') (While cond' stmt')
|
||||
else
|
||||
error "While condition must be of type boolean"
|
||||
|
||||
typeCheckStatement (Block statements) symtab classes =
|
||||
let
|
||||
processStatements (accSts, currentSymtab, types) stmt =
|
||||
let
|
||||
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
||||
stmtType = getTypeFromStmt checkedStmt
|
||||
in case stmt of
|
||||
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
||||
let
|
||||
checkedExpr = fmap (\expr -> typeCheckExpression expr currentSymtab classes) maybeExpr
|
||||
newSymtab = (identifier, dataType) : currentSymtab
|
||||
in (accSts ++ [checkedStmt], newSymtab, types)
|
||||
|
||||
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
||||
|
||||
-- Initial accumulator: empty statements list, initial symbol table, empty types list
|
||||
(checkedStatements, finalSymtab, collectedTypes) = foldl processStatements ([], symtab, []) statements
|
||||
|
||||
-- Determine the block's type: unify all collected types, default to "Void" if none
|
||||
blockType = if null collectedTypes then "void" else foldl1 unifyReturnTypes collectedTypes
|
||||
|
||||
in TypedStatement blockType (Block checkedStatements)
|
||||
|
||||
typeCheckStatement (Return expr) symtab classes =
|
||||
let expr' = case expr of
|
||||
Just e -> Just (typeCheckExpression e symtab classes)
|
||||
Nothing -> Nothing
|
||||
in case expr' of
|
||||
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
||||
Nothing -> TypedStatement "Void" (Return Nothing)
|
||||
|
||||
-- ********************************** Type Checking: Helpers **********************************
|
||||
|
||||
getTypeFromExpr :: Expression -> DataType
|
||||
getTypeFromExpr (TypedExpression t _) = t
|
||||
getTypeFromExpr _ = error "Untyped expression found where typed was expected"
|
||||
|
||||
getTypeFromStmt :: Statement -> DataType
|
||||
getTypeFromStmt (TypedStatement t _) = t
|
||||
getTypeFromStmt _ = error "Untyped statement found where typed was expected"
|
||||
|
||||
getTypeFromStmtExpr :: StatementExpression -> DataType
|
||||
getTypeFromStmtExpr (TypedStatementExpression t _) = t
|
||||
getTypeFromStmtExpr _ = error "Untyped statement expression found where typed was expected"
|
||||
|
||||
unifyReturnTypes :: DataType -> DataType -> DataType
|
||||
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")
|
||||
@ -3,6 +3,7 @@ module Example where
|
||||
import Ast
|
||||
import Control.Exception (catch, evaluate, SomeException, displayException)
|
||||
import Control.Exception.Base
|
||||
import Typecheck
|
||||
|
||||
-- Example classes and their methods and fields
|
||||
sampleClasses :: [Class]
|
||||
|
||||
@ -1,9 +1,8 @@
|
||||
module Main where
|
||||
|
||||
import Parser.Lexer
|
||||
import Example
|
||||
import Typecheck
|
||||
|
||||
main = do
|
||||
--print $ alexScanTokens "/**/"
|
||||
Example.runTypeCheck
|
||||
|
||||
290
src/Typecheck.hs
Normal file
290
src/Typecheck.hs
Normal file
@ -0,0 +1,290 @@
|
||||
module Typecheck where
|
||||
import Data.List (find)
|
||||
import Ast
|
||||
|
||||
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
|
||||
typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
|
||||
|
||||
typeCheckClass :: Class -> [Class] -> Class
|
||||
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
|
||||
in Class className checkedMethods fields
|
||||
|
||||
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
|
||||
let
|
||||
-- Combine class fields with method parameters to form the initial symbol table for the method
|
||||
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||
-- Ensure method parameters shadow class fields if names collide
|
||||
initialSymtab = classFields ++ methodParams
|
||||
-- Type check the body of the method using the combined symbol table
|
||||
checkedBody = typeCheckStatement body initialSymtab classes
|
||||
bodyType = getTypeFromStmt checkedBody
|
||||
-- Check if the type of the body matches the declared return type
|
||||
in if bodyType == retType || (bodyType == "void" && retType == "void")
|
||||
then MethodDeclaration retType name params checkedBody
|
||||
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||
|
||||
-- ********************************** Type Checking: Expressions **********************************
|
||||
|
||||
typeCheckExpression :: Expression -> [(Identifier, DataType)] -> [Class] -> Expression
|
||||
typeCheckExpression (IntegerLiteral i) _ _ = TypedExpression "int" (IntegerLiteral i)
|
||||
typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (CharacterLiteral c)
|
||||
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)
|
||||
typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
|
||||
let expr1' = typeCheckExpression expr1 symtab classes
|
||||
expr2' = typeCheckExpression expr2 symtab classes
|
||||
type1 = getTypeFromExpr expr1'
|
||||
type2 = getTypeFromExpr expr2'
|
||||
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) ->
|
||||
-- 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) ->
|
||||
-- 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"
|
||||
|
||||
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
in case op of
|
||||
Not ->
|
||||
if type' == "boolean"
|
||||
then
|
||||
TypedExpression "boolean" (UnaryOperation op expr')
|
||||
else
|
||||
error "Logical NOT operation requires an operand of type boolean"
|
||||
Minus ->
|
||||
if type' == "int"
|
||||
then
|
||||
TypedExpression "int" (UnaryOperation op expr')
|
||||
else
|
||||
error "Unary minus operation requires an operand of type int"
|
||||
|
||||
typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
||||
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||
in TypedExpression (getTypeFromStmtExpr stmtExpr') (StatementExpressionExpression stmtExpr')
|
||||
|
||||
-- ********************************** Type Checking: StatementExpressions **********************************
|
||||
-- TODO: Implement type checking for StatementExpressions
|
||||
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
||||
typeCheckStatementExpression (Assignment id expr) symtab classes =
|
||||
let expr' = typeCheckExpression expr symtab classes
|
||||
type' = getTypeFromExpr expr'
|
||||
type'' = lookupType id symtab
|
||||
in if type' == type''
|
||||
then
|
||||
TypedStatementExpression type' (Assignment id expr')
|
||||
else
|
||||
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')
|
||||
|
||||
typeCheckStatementExpression (MethodCall methodName args) symtab classes =
|
||||
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||
in TypedStatementExpression "Object" (MethodCall methodName args')
|
||||
|
||||
-- ********************************** Type Checking: Statements **********************************
|
||||
|
||||
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
|
||||
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
thenStmt' = typeCheckStatement thenStmt symtab classes
|
||||
elseStmt' = case elseStmt of
|
||||
Just stmt -> Just (typeCheckStatement stmt symtab classes)
|
||||
Nothing -> Nothing
|
||||
in if getTypeFromExpr cond' == "boolean"
|
||||
then
|
||||
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
|
||||
else
|
||||
error "If condition must be of type boolean"
|
||||
|
||||
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType 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"
|
||||
else
|
||||
-- If there's an initializer expression, type check it
|
||||
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||
exprType = fmap getTypeFromExpr checkedExpr
|
||||
in case exprType of
|
||||
Just t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||
_ -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||
|
||||
typeCheckStatement (While cond stmt) symtab classes =
|
||||
let cond' = typeCheckExpression cond symtab classes
|
||||
stmt' = typeCheckStatement stmt symtab classes
|
||||
in if getTypeFromExpr cond' == "boolean"
|
||||
then
|
||||
TypedStatement (getTypeFromStmt stmt') (While cond' stmt')
|
||||
else
|
||||
error "While condition must be of type boolean"
|
||||
|
||||
typeCheckStatement (Block statements) symtab classes =
|
||||
let
|
||||
processStatements (accSts, currentSymtab, types) stmt =
|
||||
let
|
||||
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
||||
stmtType = getTypeFromStmt checkedStmt
|
||||
in case stmt of
|
||||
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
||||
let
|
||||
checkedExpr = fmap (\expr -> typeCheckExpression expr currentSymtab classes) maybeExpr
|
||||
newSymtab = (identifier, dataType) : currentSymtab
|
||||
in (accSts ++ [checkedStmt], newSymtab, types)
|
||||
|
||||
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
||||
|
||||
-- Initial accumulator: empty statements list, initial symbol table, empty types list
|
||||
(checkedStatements, finalSymtab, collectedTypes) = foldl processStatements ([], symtab, []) statements
|
||||
|
||||
-- Determine the block's type: unify all collected types, default to "Void" if none
|
||||
blockType = if null collectedTypes then "void" else foldl1 unifyReturnTypes collectedTypes
|
||||
|
||||
in TypedStatement blockType (Block checkedStatements)
|
||||
|
||||
typeCheckStatement (Return expr) symtab classes =
|
||||
let expr' = case expr of
|
||||
Just e -> Just (typeCheckExpression e symtab classes)
|
||||
Nothing -> Nothing
|
||||
in case expr' of
|
||||
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
||||
Nothing -> TypedStatement "Void" (Return Nothing)
|
||||
|
||||
-- ********************************** Type Checking: Helpers **********************************
|
||||
|
||||
getTypeFromExpr :: Expression -> DataType
|
||||
getTypeFromExpr (TypedExpression t _) = t
|
||||
getTypeFromExpr _ = error "Untyped expression found where typed was expected"
|
||||
|
||||
getTypeFromStmt :: Statement -> DataType
|
||||
getTypeFromStmt (TypedStatement t _) = t
|
||||
getTypeFromStmt _ = error "Untyped statement found where typed was expected"
|
||||
|
||||
getTypeFromStmtExpr :: StatementExpression -> DataType
|
||||
getTypeFromStmtExpr (TypedStatementExpression t _) = t
|
||||
getTypeFromStmtExpr _ = error "Untyped statement expression found where typed was expected"
|
||||
|
||||
unifyReturnTypes :: DataType -> DataType -> DataType
|
||||
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")
|
||||
Loading…
Reference in New Issue
Block a user