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

Added cardinality to type checking

Browse Source
This commit is contained in:
macocianradu
2021-12-01 01:40:26 +01:00
parent ff25395b68
commit 9210c78beb
5 changed files with 120 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
resources/testAll.rosetta
View File

@@ -24,11 +24,11 @@ type ObservationPrimitive:
func EquityPriceObservation: <"Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class.">
inputs:
equity int (1..1)
valuationDate int (1..1)
valuationDate ObservationPrimitive (1..1)
valuationTime int (0..1)
timeType TestType (0..1)
determinationMethod ObservationPrimitive (1..*)
output:
observation ObservationPrimitive (1..1)
observation ObservationPrimitive (0..1)
assign-output: if equity exists then valuationDate

13
src/Model/Type.hs
View File

@@ -40,4 +40,15 @@ data Cardinality =
| OneBound Integer
-- |The cardinality of no bounds (ex. * - *)
| NoBounds
deriving Show
deriving Show
instance Eq Cardinality where
(==) (Bounds (x1, x2)) (Bounds (y1, y2))
| x1 == y1 && x2 == y2 = True
| otherwise = False
(==) (OneBound x) (OneBound y) = x == y
(==) NoBounds NoBounds = True
(==) _ _ = False
typeAndCardinality :: TypeAttribute -> (Type, Cardinality)
typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd)

163
src/Semantic/ExpressionChecker.hs
View File

@@ -9,55 +9,57 @@ import Semantic.TypeChecker
-- |A declared variable or function
data Symbol = Var{
varName :: String,
declaredType :: Type
declaredType :: Type,
cardinality :: Cardinality
}
| Func {
funcName :: String,
argsType :: [Type],
returnType :: Type
}
argsType :: [(Type, Cardinality)],
returnType :: (Type, Cardinality)
} deriving (Show)
-- |A map of the predefined functions, their arguments and their return type
defaultMap :: [Symbol]
defaultMap = [
Func "or" [BasicType "Boolean", BasicType "Boolean"] (BasicType "Boolean"),
Func "and" [BasicType "Boolean", BasicType "Boolean"] (BasicType "Boolean"),
Func "exists" [BasicType "Any"] (BasicType "Boolean"),
Func "is absent" [BasicType "Any"] (BasicType "Boolean"),
Func "single exists" [BasicType "Any"] (BasicType "Boolean"),
Func "multiple exists" [BasicType "Any"] (BasicType "Boolean"),
Func "contains" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "disjoint" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "or" [(BasicType "Boolean", Bounds (1, 1)), (BasicType "Boolean", Bounds (1, 1))] (BasicType "Boolean", Bounds (1, 1)),
Func "and" [(BasicType "Boolean", Bounds (1, 1)), (BasicType "Boolean", Bounds (1, 1))] (BasicType "Boolean", Bounds (1, 1)),
Func "exists" [(BasicType "Any", Bounds (0, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "is absent" [(BasicType "Any", Bounds (0, 1))] (BasicType "Boolean", Bounds (1, 1)),
Func "single exists" [(BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds (1, 1)),
Func "multiple exists" [(BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds (1, 1)),
Func "contains" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds (1, 1)),
Func "disjoint" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds (1, 1)),
Func "=" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func ">=" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "<=" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "<>" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func ">" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "<" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "all =" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "all <>" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "any =" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "any <>" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
Func "=" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds(1, 1)),
Func ">=" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds(1, 1)),
Func "<=" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds(1, 1)),
Func "<>" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds(1, 1)),
Func ">" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds(1, 1)),
Func "<" [(BasicType "Any", NoBounds), (BasicType "Any", NoBounds)] (BasicType "Boolean", Bounds(1, 1)),
Func "all =" [(BasicType "Any", NoBounds), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "all <>" [(BasicType "Any", NoBounds), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "any =" [(BasicType "Any", NoBounds), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "any <>" [(BasicType "Any", NoBounds), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)),
Func "+" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
Func "+" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
Func "-" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
Func "-" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
Func "*" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
Func "*" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
Func "/" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
Func "/" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
Func "^" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
Func "^" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
Func "+" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "+" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "-" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "-" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "*" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "*" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "/" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "/" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "^" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)),
Func "^" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)),
Func "count" [BasicType "Any"] (BasicType "Integer")
Func "count" [(BasicType "Any", NoBounds)] (BasicType "Integer", Bounds (1, 1))
]
-- |Checks whether a function is valid (inputs, outputs are of valid type and all variables are defined) and adds it to the symbol table
addFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] [Symbol]
addFunction (definedTypes, definedSymbols) (MakeFunction name _ inps out _)
| null (lefts checkedInputs) && isRight checkedOutput = Right $ Func name (map attributeType (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput) : allSymbols
| null (lefts checkedInputs) && isRight checkedOutput = Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput, Model.Type.cardinality out) : allSymbols
| isLeft checkedOutput = Left [fromLeftUnsafe checkedOutput]
| otherwise = Left $ lefts checkedInputs
where
@@ -68,15 +70,15 @@ addFunction (definedTypes, definedSymbols) (MakeFunction name _ inps out _)
-- |Adds a newly defined variable to the symbol table
addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol]
addVariables s [] = s
addVariables s ((MakeTypeAttribute name typ _ _) : vars) = Var name typ : addVariables s vars
addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name typ crd : addVariables s vars
-- |Checks the type of a given expression
checkExpression :: [Symbol] -> Expression -> Either TypeCheckError Type
checkExpression :: [Symbol] -> Expression -> Either TypeCheckError (Type, Cardinality)
checkExpression symbolMap (Variable var) = findVarType var symbolMap
checkExpression _ (Int _) = Right $ BasicType "Integer"
checkExpression _ (Real _) = Right $ BasicType "Double"
checkExpression _ (Boolean _) = Right $ BasicType "Boolean"
checkExpression _ Empty = Right $ BasicType "Empty"
checkExpression _ (Int _) = Right (BasicType "Integer", Bounds (1, 1))
checkExpression _ (Real _) = Right (BasicType "Double", Bounds (1, 1))
checkExpression _ (Boolean _) = Right (BasicType "Boolean", Bounds (1, 1))
checkExpression _ Empty = Right (BasicType "Empty", Bounds (0, 0))
checkExpression symbolMap (Parens ex) = checkExpression symbolMap ex
checkExpression symbolMap (List lst) = checkList symbolMap lst
checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
@@ -85,27 +87,35 @@ checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap nam
checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2])
-- |Checks if the condition of an if expression is of type boolean, and then checks the expression of the then statement
checkExpression symbolMap (IfSimple cond ex)
| isRight condType && isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex
| otherwise = Left IfConditionNotBoolean
where condType = checkExpression symbolMap cond
| isRight condType && isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean", Bounds (1, 1))) =
case checkedExp of
-- |The if without else statement always has a cardinality lower bound of 0
Right (typ, Bounds(_, x)) -> Right (typ, Bounds(0, x))
-- |The unbounded or semi-bounded cardinalities already have 0 included
Right x -> Right x
Left err -> Left err
| otherwise = Left $ IfConditionNotBoolean $ show condType ++ " | " ++ show (getVars symbolMap)
where
condType = checkExpression symbolMap cond
checkedExp = checkExpression symbolMap ex
-- |Checks if the condition of the if statement is of type boolean, and then checks that both the then and else statements have the same type
checkExpression symbolMap (IfElse cond ex1 ex2)
| isRight condType || isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = Left IfConditionNotBoolean
| isRight ex1Type || isRight ex2Type || isRight (typeMatch (fromRightUnsafe ex1Type) (fromRightUnsafe ex2Type)) = Left IfExpressionsDifferentTypes
| isRight condType || isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean", Bounds (1, 1))) = Left $ IfConditionNotBoolean $ show cond
| isRight ex1Type || isRight ex2Type || isRight (typeMatch (fromRightUnsafe ex1Type) (fromRightUnsafe ex2Type)) = Left $ IfExpressionsDifferentTypes (show ex1) (show ex2)
| otherwise = ex1Type
where condType = checkExpression symbolMap cond
ex1Type = checkExpression symbolMap ex1
ex2Type = checkExpression symbolMap ex2
-- |Checks that all the expressions in a list have compatible types
checkList :: [Symbol] -> [Expression] -> Either TypeCheckError Type
checkList :: [Symbol] -> [Expression] -> Either TypeCheckError (Type, Cardinality)
checkList symbs exps
| isRight typ && fromRightUnsafe typ == BasicType "Any" = Right $ BasicType "Empty"
| isRight typ && fromRightUnsafe typ == (BasicType "Any", NoBounds) = Right (BasicType "Empty", Bounds (0, 0))
| otherwise = typ
where typ = checkList1 symbs exps (BasicType "Any")
where typ = checkList1 symbs exps (BasicType "Any", NoBounds)
-- |Auxiliary function for the check list function
checkList1 :: [Symbol] -> [Expression] -> Type -> Either TypeCheckError Type
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError (Type, Cardinality)
checkList1 _ [] typ = Right typ
checkList1 symbs (ex : exps) typ
| isRight exTyp = exTyp
@@ -116,10 +126,10 @@ checkList1 symbs (ex : exps) typ
match = typeMatch typ (fromRightUnsafe exTyp)
-- |Checks whether the function that is called is already defined with the same argument types
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError Type] -> Either TypeCheckError Type
checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap typeName (rights args) ++ "]"
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError (Type, Cardinality)] -> Either TypeCheckError (Type, Cardinality)
checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap (typeName . fst) (rights args) ++ "]"
checkFunctionCall ((Func n a r):symbolMap) name args
| length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args)
| length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args))
| name == n && all isRight (zipWith typeMatch a right) = Right r
| otherwise = checkFunctionCall symbolMap name args
where right = rights args
@@ -127,21 +137,46 @@ checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name arg
--Try to match 2nd type to first type
-- |Checks whether two types are compatible
typeMatch :: Type -> Type -> Either TypeCheckError Type
typeMatch (BasicType "Any") x = Right x
typeMatch (BasicType "Double") (BasicType "Integer") = Right $ BasicType "Dobule"
typeMatch s (BasicType s2)
| s == BasicType s2 = Right s
| otherwise = Left $ TypeMismatch (typeName s) s2
typeMatch s s2
| s == s2 = Right s
| isJust $ superType s2 = typeMatch s (fromJust $ superType s2)
typeMatch :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError (Type, Cardinality)
typeMatch (BasicType "Any", card1) (x, card2)
| isRight card = Right (x, fromRightUnsafe card)
| otherwise = Left $ fromLeftUnsafe card
where card = cardinalityIncluded card2 card1
typeMatch (BasicType "Double", card1) (BasicType "Integer", card2)
| isRight card = Right (BasicType "Dobule", fromRightUnsafe card)
| otherwise = Left $ fromLeftUnsafe card
where card = cardinalityIncluded card2 card1
--typeMatch (s, card1) (BasicType s2, card2)
-- | s == BasicType s2 = case cardinalityIncluded card1 card2 of
-- Right card -> Right (s, card)
-- Left err -> Left err
-- | otherwise = Left $ TypeMismatch (typeName s) s2
typeMatch (s, card1) (s2, card2)
| s == s2 = case cardinalityIncluded card2 card1 of
Right card -> Right (s, card)
Left err -> Left err
| isJust $ superType s2 = typeMatch (s, card1) (fromJust $ superType s2, card2)
| otherwise = Left $ TypeMismatch (typeName s) (typeName s2)
-- |Checks whether the first cardinality is included into the second one and returns the most restricted cardinality
cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError Cardinality
cardinalityIncluded x NoBounds = Right x
cardinalityIncluded NoBounds x = Left $ CardinalityMismatch NoBounds x
cardinalityIncluded (OneBound x) (OneBound y)
| x >= y = Right $ OneBound x
| otherwise = Left $ CardinalityMismatch (OneBound x) (OneBound y)
cardinalityIncluded (Bounds (x1, x2)) (OneBound y)
| x1 >= y = Right $ Bounds (x1, x2)
| otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (OneBound y)
cardinalityIncluded (OneBound x) (Bounds (y1, y2)) = Left $ CardinalityMismatch (OneBound x) (Bounds (y1, y2))
cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
| x1 >= y1 && x2 <= y2 = Right $ Bounds (x1, x2)
| otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (Bounds (y1, y2))
-- |Looks in the symbol map for the type of a variable
findVarType :: String -> [Symbol] -> Either TypeCheckError Type
findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality)
findVarType var [] = Left $ UndefinedVariable var
findVarType x ((Var name typ):symbols)
| x == name = Right typ
findVarType x ((Var name typ crd):symbols)
| x == name = Right (typ, crd)
| otherwise = findVarType x symbols
findVarType x (_:symbols) = findVarType x symbols

5
src/Semantic/FunctionChecker.hs
View File

@@ -9,7 +9,10 @@ import Data.Either
-- |Checks if all the inputs and the out of a function call have valid types, and then checks that the assign-output expression is valid
checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] Function
checkFunction (definedTypes, definedFunctions) (MakeFunction name desc inp out ex)
| isRight checkedEx && isRight checkedOut && null (lefts checkedIn) = Right $ MakeFunction name desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
| isRight checkedEx && isRight checkedOut && null (lefts checkedIn) =
case typeMatch (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) (fromRightUnsafe checkedEx) of
Right _ -> Right $ MakeFunction name desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
Left err -> Left [err]
| otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx]
where
checkedEx = checkExpression definedFunctions ex

5
src/Semantic/TypeChecker.hs
View File

@@ -6,12 +6,13 @@ import Data.Either
-- |A datatype for the different types of type check errors
data TypeCheckError =
UndefinedType String
| IfConditionNotBoolean
| IfExpressionsDifferentTypes
| IfConditionNotBoolean String
| IfExpressionsDifferentTypes String String
| UndefinedFunction String
| ErrorInsideFunction String
| UndefinedVariable String
| TypeMismatch String String
| CardinalityMismatch Cardinality Cardinality
deriving (Show)
-- |Checks whether a data type is valid