radumaco/RosettaHaskellCompiler
1
0
Fork 0
mirror of https://github.com/macocianradu/RosettaHaskellCompiler.git synced 2026-03-18 13:00:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Switched to have error on left and data type on right

Browse Source
This commit is contained in:
macocianradu
2021-11-12 00:51:43 +01:00
parent 6367fb7c45
commit 045ae7049e
2 changed files with 39 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
src/Semantic/ExpressionChecker.hs
View File

@@ -52,12 +52,12 @@ defaultMap = [
Func "count" [BasicType "Any"] (BasicType "Integer") Func "count" [BasicType "Any"] (BasicType "Integer")
] ]
checkExpression :: [Symbol] -> Expression -> Either Type TypeCheckError checkExpression :: [Symbol] -> Expression -> Either TypeCheckError Type
checkExpression symbolMap (Variable var) = findVarType var symbolMap checkExpression symbolMap (Variable var) = findVarType var symbolMap
checkExpression _ (Int _) = Left $ BasicType "Integer" checkExpression _ (Int _) = Right $ BasicType "Integer"
checkExpression _ (Real _) = Left $ BasicType "Double" checkExpression _ (Real _) = Right $ BasicType "Double"
checkExpression _ (Boolean _) = Left $ BasicType "Boolean" checkExpression _ (Boolean _) = Right $ BasicType "Boolean"
checkExpression _ Empty = Left $ BasicType "Empty" checkExpression _ Empty = Right $ BasicType "Empty"
checkExpression symbolMap (Parens ex) = checkExpression symbolMap ex checkExpression symbolMap (Parens ex) = checkExpression symbolMap ex
checkExpression symbolMap (List lst) = checkList symbolMap lst checkExpression symbolMap (List lst) = checkList symbolMap lst
checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
@@ -65,58 +65,58 @@ checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap nam
checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2]) checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2])
checkExpression symbolMap (IfSimple cond ex) checkExpression symbolMap (IfSimple cond ex)
| isLeft condType && isLeft (typeMatch (fromLeftUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex | isLeft condType && isLeft (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex
| otherwise = Right IfConditionNotBoolean | otherwise = Left IfConditionNotBoolean
where condType = checkExpression symbolMap cond where condType = checkExpression symbolMap cond
checkExpression symbolMap (IfElse cond ex1 ex2) checkExpression symbolMap (IfElse cond ex1 ex2)
| isRight condType || isRight (typeMatch (fromLeftUnsafe condType) (BasicType "Boolean")) = Right IfConditionNotBoolean | isRight condType || isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = Left IfConditionNotBoolean
| isRight ex1Type || isRight ex2Type || isRight (typeMatch (fromLeftUnsafe ex1Type) (fromLeftUnsafe ex2Type)) = Right IfExpressionsDifferentTypes | isRight ex1Type || isRight ex2Type || isRight (typeMatch (fromRightUnsafe ex1Type) (fromRightUnsafe ex2Type)) = Left IfExpressionsDifferentTypes
| otherwise = ex1Type | otherwise = ex1Type
where condType = checkExpression symbolMap cond where condType = checkExpression symbolMap cond
ex1Type = checkExpression symbolMap ex1 ex1Type = checkExpression symbolMap ex1
ex2Type = checkExpression symbolMap ex2 ex2Type = checkExpression symbolMap ex2
checkList :: [Symbol] -> [Expression] -> Either Type TypeCheckError checkList :: [Symbol] -> [Expression] -> Either TypeCheckError Type
checkList symbs exps checkList symbs exps
| isLeft typ && fromLeftUnsafe typ == BasicType "Any" = Left $ BasicType "Empty" | isRight typ && fromRightUnsafe typ == BasicType "Any" = Right $ BasicType "Empty"
| otherwise = typ | otherwise = typ
where typ = checkList1 symbs exps (BasicType "Any") where typ = checkList1 symbs exps (BasicType "Any")
checkList1 :: [Symbol] -> [Expression] -> Type -> Either Type TypeCheckError checkList1 :: [Symbol] -> [Expression] -> Type -> Either TypeCheckError Type
checkList1 _ [] typ = Left typ checkList1 _ [] typ = Right typ
checkList1 symbs (ex : exps) typ checkList1 symbs (ex : exps) typ
| isRight exTyp = exTyp | isRight exTyp = exTyp
| isRight match = match | isRight match = match
| otherwise = checkList1 symbs exps (fromLeftUnsafe match) | otherwise = checkList1 symbs exps (fromRightUnsafe match)
where where
exTyp = checkExpression symbs ex exTyp = checkExpression symbs ex
match = typeMatch typ (fromLeftUnsafe exTyp) match = typeMatch typ (fromRightUnsafe exTyp)
checkFunctionCall :: [Symbol] -> String -> [Either Type TypeCheckError] -> Either Type TypeCheckError checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError Type] -> Either TypeCheckError Type
checkFunctionCall [] fun args = Right $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap typeName (lefts args) ++ "]" checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap typeName (rights args) ++ "]"
checkFunctionCall ((Func n a r):symbolMap) name args checkFunctionCall ((Func n a r):symbolMap) name args
| length left /= length args = Right ErrorInsideFunction | length right /= length args = Left ErrorInsideFunction
| name == n && all isLeft (zipWith typeMatch a left) = Left r | name == n && all isRight (zipWith typeMatch a right) = Right r
| otherwise = checkFunctionCall symbolMap name args | otherwise = checkFunctionCall symbolMap name args
where left = lefts args where right = rights args
checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args
--Try to match 2nd type to first type --Try to match 2nd type to first type
typeMatch :: Type -> Type -> Either Type TypeCheckError typeMatch :: Type -> Type -> Either TypeCheckError Type
typeMatch (BasicType "Any") x = Left x typeMatch (BasicType "Any") x = Right x
typeMatch (BasicType "Double") (BasicType "Integer") = Left $ BasicType "Dobule" typeMatch (BasicType "Double") (BasicType "Integer") = Right $ BasicType "Dobule"
typeMatch s (BasicType s2) typeMatch s (BasicType s2)
| s == BasicType s2 = Left s | s == BasicType s2 = Right s
| otherwise = Right $ TypeMismatch (typeName s) s2 | otherwise = Left $ TypeMismatch (typeName s) s2
typeMatch s s2 typeMatch s s2
| s == s2 = Left s | s == s2 = Right s
| isJust $ superType s2 = typeMatch s (fromJust $ superType s2) | isJust $ superType s2 = typeMatch s (fromJust $ superType s2)
| otherwise = Right $ TypeMismatch (typeName s) (typeName s2) | otherwise = Left $ TypeMismatch (typeName s) (typeName s2)
findVarType :: String -> [Symbol] -> Either Type TypeCheckError findVarType :: String -> [Symbol] -> Either TypeCheckError Type
findVarType var [] = Right $ UndefinedVariable var findVarType var [] = Left $ UndefinedVariable var
findVarType x ((Var name typ):symbols) findVarType x ((Var name typ):symbols)
| x == name = Left typ | x == name = Right typ
| otherwise = findVarType x symbols | otherwise = findVarType x symbols
findVarType x (_:symbols) = findVarType x symbols findVarType x (_:symbols) = findVarType x symbols

18
src/Semantic/TypeChecker.hs
View File

@@ -12,19 +12,19 @@ data TypeCheckError =
| TypeMismatch String String | TypeMismatch String String
deriving (Show) deriving (Show)
checkAttributes :: [Type] -> [TypeAttribute] -> [Either Type TypeCheckError] checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError Type]
checkAttributes _ [] = [] checkAttributes _ [] = []
checkAttributes definedTypes ((MakeTypeAttribute _ name _ _):as) = checkType definedTypes name : checkAttributes definedTypes as checkAttributes definedTypes ((MakeTypeAttribute _ name _ _):as) = checkType definedTypes name : checkAttributes definedTypes as
checkType :: [Type] -> Type -> Either Type TypeCheckError checkType :: [Type] -> Type -> Either TypeCheckError Type
checkType _ (MakeType "int" _ _ _) = Left $ BasicType "Integer" checkType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer"
checkType _ (MakeType "string" _ _ _) = Left $ BasicType "String" checkType _ (MakeType "string" _ _ _) = Right $ BasicType "String"
checkType _ (MakeType "number" _ _ _) = Left $ BasicType "Double" checkType _ (MakeType "number" _ _ _) = Right $ BasicType "Double"
checkType _ (MakeType "boolean" _ _ _) = Left $ BasicType "Bool" checkType _ (MakeType "boolean" _ _ _) = Right $ BasicType "Bool"
checkType _ (MakeType "time" _ _ _) = Left $ BasicType "Time" checkType _ (MakeType "time" _ _ _) = Right $ BasicType "Time"
checkType definedTypes name checkType definedTypes name
| name `elem` definedTypes = Left name | name `elem` definedTypes = Right name
| otherwise = Right $ UndefinedType (typeName name) | otherwise = Left $ UndefinedType (typeName name)
addDefinedTypes :: [Type] -> [Type] -> [Type] addDefinedTypes :: [Type] -> [Type] -> [Type]
addDefinedTypes l [] = l addDefinedTypes l [] = l