mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 21:10:07 +00:00
Made super mandatory. Everything extends Object
This commit is contained in:
@@ -73,7 +73,7 @@ addNewFunctions (t, s) (_:os) = addNewFunctions (t, s) os
|
|||||||
addNewTypes :: [Type] -> [RosettaObject] -> [Type]
|
addNewTypes :: [Type] -> [RosettaObject] -> [Type]
|
||||||
addNewTypes l [] = l
|
addNewTypes l [] = l
|
||||||
addNewTypes defined (TypeObject o: os) = addDefinedTypes (addNewTypes defined os) [o]
|
addNewTypes defined (TypeObject o: os) = addDefinedTypes (addNewTypes defined os) [o]
|
||||||
addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addDefinedTypes (addNewTypes defined os) [MakeType name Nothing Nothing []]
|
addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addDefinedTypes (addNewTypes defined os) [MakeType name (BasicType "Object") Nothing []]
|
||||||
addNewTypes defined (_ :os) = addNewTypes defined os
|
addNewTypes defined (_ :os) = addNewTypes defined os
|
||||||
|
|
||||||
-- |Parses any supported Rosetta types into a list of RosettaObject
|
-- |Parses any supported Rosetta types into a list of RosettaObject
|
||||||
|
|||||||
20
resources/Types/testType8.rosetta
Normal file
20
resources/Types/testType8.rosetta
Normal file
@@ -0,0 +1,20 @@
|
|||||||
|
type A: <"description">
|
||||||
|
a int (1..1) <"A">
|
||||||
|
|
||||||
|
type B extending A: <"description">
|
||||||
|
b int (1..1) <"B">
|
||||||
|
|
||||||
|
type C extending A: <"description">
|
||||||
|
c int (1..1) <"C">
|
||||||
|
|
||||||
|
type D extending B: <"description">
|
||||||
|
d int (1..1) <"D">
|
||||||
|
|
||||||
|
type F extending B: <"description">
|
||||||
|
f int (1..1) <"F">
|
||||||
|
|
||||||
|
type G extending C: <"description">
|
||||||
|
g int (1..1) <"G">
|
||||||
|
|
||||||
|
type H extending C: <"description">
|
||||||
|
h int (1..1) <"H">
|
||||||
@@ -5,7 +5,7 @@ import Data.Time.LocalTime()
|
|||||||
-- |The representation of a Rosetta data type
|
-- |The representation of a Rosetta data type
|
||||||
data Type = MakeType {
|
data Type = MakeType {
|
||||||
typeName :: String,
|
typeName :: String,
|
||||||
superType :: Maybe Type,
|
superType :: Type,
|
||||||
typeDescription :: Maybe String,
|
typeDescription :: Maybe String,
|
||||||
typeAttributes :: [TypeAttribute]
|
typeAttributes :: [TypeAttribute]
|
||||||
}
|
}
|
||||||
@@ -49,6 +49,23 @@ instance Eq Cardinality where
|
|||||||
(==) (OneBound x) (OneBound y) = x == y
|
(==) (OneBound x) (OneBound y) = x == y
|
||||||
(==) NoBounds NoBounds = True
|
(==) NoBounds NoBounds = True
|
||||||
(==) _ _ = False
|
(==) _ _ = False
|
||||||
|
|
||||||
|
-- |A function used to add two cardinalities
|
||||||
|
addBounds :: Cardinality -> Cardinality -> Cardinality
|
||||||
|
addBounds (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (x1 + y1, x2 + y2)
|
||||||
|
addBounds (Bounds (x1, _)) (OneBound y1) = OneBound (x1 + y1)
|
||||||
|
addBounds (Bounds (x1, _)) NoBounds = OneBound x1
|
||||||
|
addBounds (OneBound x1) (Bounds (y1, y2)) = addBounds (Bounds (y1, y2)) (OneBound x1)
|
||||||
|
addBounds (OneBound x1) (OneBound y1) = OneBound (x1 + y1)
|
||||||
|
addBounds (OneBound x1) NoBounds = OneBound x1
|
||||||
|
addBounds NoBounds (Bounds (y1, y2)) = addBounds (Bounds (y1, y2)) NoBounds
|
||||||
|
addBounds NoBounds (OneBound y1) = addBounds (OneBound y1) NoBounds
|
||||||
|
addBounds NoBounds NoBounds = NoBounds
|
||||||
|
|
||||||
|
-- |Custom operator for adding cardinalities
|
||||||
|
infixl 5 .+
|
||||||
|
(.+) :: Cardinality -> Cardinality -> Cardinality
|
||||||
|
(.+) = addBounds
|
||||||
|
|
||||||
typeAndCardinality :: TypeAttribute -> (Type, Cardinality)
|
typeAndCardinality :: TypeAttribute -> (Type, Cardinality)
|
||||||
typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd)
|
typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd)
|
||||||
@@ -52,5 +52,5 @@ attributeParser =
|
|||||||
typ <- try (pascalNameParser <|> camelNameParser)
|
typ <- try (pascalNameParser <|> camelNameParser)
|
||||||
crd <- cardinalityParser
|
crd <- cardinalityParser
|
||||||
desc <- optional descriptionParser
|
desc <- optional descriptionParser
|
||||||
return $ MakeTypeAttribute nam (MakeType typ Nothing Nothing []) crd desc
|
return $ MakeTypeAttribute nam (MakeType typ (BasicType "Object") Nothing []) crd desc
|
||||||
|
|
||||||
@@ -5,6 +5,7 @@ module Parser.Type where
|
|||||||
import Model.Type
|
import Model.Type
|
||||||
import Text.Megaparsec.Char
|
import Text.Megaparsec.Char
|
||||||
import Text.Megaparsec
|
import Text.Megaparsec
|
||||||
|
import Data.Maybe
|
||||||
import Parser.General
|
import Parser.General
|
||||||
|
|
||||||
-- |Parses a type declaration statement in Rosetta into an Type
|
-- |Parses a type declaration statement in Rosetta into an Type
|
||||||
@@ -16,7 +17,7 @@ typeParser =
|
|||||||
_ <- lexeme $ char ':'
|
_ <- lexeme $ char ':'
|
||||||
tDescription <- optional descriptionParser
|
tDescription <- optional descriptionParser
|
||||||
tAttributes <- many $ try typeAttributeParser
|
tAttributes <- many $ try typeAttributeParser
|
||||||
return (MakeType tName tSuper tDescription tAttributes)
|
if isJust tSuper then return (MakeType tName (fromJust tSuper) tDescription tAttributes) else return (MakeType tName (BasicType "Object") tDescription tAttributes)
|
||||||
|
|
||||||
-- |Parses the super class declaration statement in Rosetta into an Type
|
-- |Parses the super class declaration statement in Rosetta into an Type
|
||||||
superTypeParser :: Parser Type
|
superTypeParser :: Parser Type
|
||||||
@@ -24,7 +25,7 @@ superTypeParser =
|
|||||||
do
|
do
|
||||||
_ <- lexeme $ string "extends"
|
_ <- lexeme $ string "extends"
|
||||||
name <- pascalNameParser
|
name <- pascalNameParser
|
||||||
return $ MakeType name Nothing Nothing []
|
return $ MakeType name (BasicType "Object") Nothing []
|
||||||
|
|
||||||
-- |Parses a declared type attribute in Rosetta into a TypeAttribute
|
-- |Parses a declared type attribute in Rosetta into a TypeAttribute
|
||||||
typeAttributeParser :: Parser TypeAttribute
|
typeAttributeParser :: Parser TypeAttribute
|
||||||
@@ -34,7 +35,7 @@ typeAttributeParser =
|
|||||||
aType <- try nameParser
|
aType <- try nameParser
|
||||||
card <- cardinalityParser
|
card <- cardinalityParser
|
||||||
desc <- optional descriptionParser
|
desc <- optional descriptionParser
|
||||||
return (MakeTypeAttribute aName (MakeType aType Nothing Nothing []) card desc)
|
return (MakeTypeAttribute aName (MakeType aType (BasicType "Object") Nothing []) card desc)
|
||||||
|
|
||||||
-- |Parses the cardinality of a type attribute in Rosetta into a Cardinality
|
-- |Parses the cardinality of a type attribute in Rosetta into a Cardinality
|
||||||
cardinalityParser :: Parser Cardinality
|
cardinalityParser :: Parser Cardinality
|
||||||
|
|||||||
@@ -8,15 +8,15 @@ import Model.Type
|
|||||||
|
|
||||||
-- |Converts an EnumType into a haskell valid String
|
-- |Converts an EnumType into a haskell valid String
|
||||||
printType :: Type -> String
|
printType :: Type -> String
|
||||||
printType (MakeType name (Just (MakeType super _ _ _)) description attributes) = printType (MakeType name Nothing description (superToAttribute name super:attributes))
|
printType (MakeType name (MakeType super _ _ _) description attributes) = printType (MakeType name (BasicType "Object") description (superToAttribute name super:attributes))
|
||||||
printType (MakeType _ (Just (BasicType _)) _ _) = error "Can't extend basic types"
|
printType (MakeType name (BasicType "Object") description attributes) =
|
||||||
printType (MakeType name Nothing description attributes) =
|
|
||||||
show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes attributes), "}", "", emptyDoc])
|
show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes attributes), "}", "", emptyDoc])
|
||||||
|
printType (MakeType _ (BasicType _) _ _) = error "Can't extend basic types"
|
||||||
printType (BasicType name) = show $ pretty name
|
printType (BasicType name) = show $ pretty name
|
||||||
|
|
||||||
-- |Creates an attribute that accesses the super type
|
-- |Creates an attribute that accesses the super type
|
||||||
superToAttribute :: String -> String -> TypeAttribute
|
superToAttribute :: String -> String -> TypeAttribute
|
||||||
superToAttribute name typ = MakeTypeAttribute ("super" ++ name) (MakeType typ Nothing Nothing []) (Bounds (1, 1)) (Just "Pointer to super class")
|
superToAttribute name typ = MakeTypeAttribute ("super" ++ name) (MakeType typ (BasicType "Object") Nothing []) (Bounds (1, 1)) (Just "Pointer to super class")
|
||||||
|
|
||||||
-- |Converts a list of TypeAttributes into a list of haskell valid Docs
|
-- |Converts a list of TypeAttributes into a list of haskell valid Docs
|
||||||
printAttributes :: [TypeAttribute] -> [Doc a]
|
printAttributes :: [TypeAttribute] -> [Doc a]
|
||||||
|
|||||||
@@ -86,7 +86,7 @@ checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap nam
|
|||||||
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])
|
||||||
-- |Checks if the condition of an if expression is of type boolean, and then checks the expression of the then statement
|
-- |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)
|
checkExpression symbolMap (IfSimple cond ex)
|
||||||
| isRight condType && isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean", Bounds (1, 1))) =
|
| isRight condType && isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) =
|
||||||
case checkedExp of
|
case checkedExp of
|
||||||
-- |The if without else statement always has a cardinality lower bound of 0
|
-- |The if without else statement always has a cardinality lower bound of 0
|
||||||
Right (typ, Bounds(_, x)) -> Right (typ, Bounds(0, x))
|
Right (typ, Bounds(_, x)) -> Right (typ, Bounds(0, x))
|
||||||
@@ -99,8 +99,11 @@ checkExpression symbolMap (IfSimple cond ex)
|
|||||||
checkedExp = checkExpression symbolMap ex
|
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
|
-- |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)
|
checkExpression symbolMap (IfElse cond ex1 ex2)
|
||||||
| isLeft condType || isLeft (typeMatch (fromRightUnsafe condType) (BasicType "Boolean", Bounds (1, 1))) = Left $ IfConditionNotBoolean $ show cond
|
| isLeft condType || isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) = Left $ IfConditionNotBoolean $ show cond
|
||||||
| isLeft ex1Type || isLeft ex2Type || isLeft (typeMatch (fromRightUnsafe ex1Type) (fromRightUnsafe ex2Type)) = Left $ IfExpressionsDifferentTypes (show ex1) (show ex2)
|
| isLeft ex1Type || isLeft ex2Type ||
|
||||||
|
-- |Both branches must resolve to the same type and cardinality
|
||||||
|
isLeft (typeMatch (fst $ fromRightUnsafe ex1Type) (fst $ fromRightUnsafe ex2Type)) ||
|
||||||
|
snd (fromRightUnsafe ex1Type) /= snd (fromRightUnsafe ex2Type) = Left $ IfExpressionsDifferentTypes (show ex1) (show ex2)
|
||||||
| otherwise = ex1Type
|
| otherwise = ex1Type
|
||||||
where condType = checkExpression symbolMap cond
|
where condType = checkExpression symbolMap cond
|
||||||
ex1Type = checkExpression symbolMap ex1
|
ex1Type = checkExpression symbolMap ex1
|
||||||
@@ -108,69 +111,82 @@ checkExpression symbolMap (IfElse cond ex1 ex2)
|
|||||||
|
|
||||||
-- |Checks that all the expressions in a list have compatible types
|
-- |Checks that all the expressions in a list have compatible types
|
||||||
checkList :: [Symbol] -> [Expression] -> Either TypeCheckError (Type, Cardinality)
|
checkList :: [Symbol] -> [Expression] -> Either TypeCheckError (Type, Cardinality)
|
||||||
checkList symbs exps
|
checkList _ [] = Right (BasicType "Empty", Bounds(0, 0))
|
||||||
| isRight typ && fromRightUnsafe typ == (BasicType "Any", NoBounds) = Right (BasicType "Empty", Bounds (0, 0))
|
checkList symbs (ex : exps)
|
||||||
|
| isRight typ = checkList1 symbs exps (fromRightUnsafe typ)
|
||||||
| otherwise = typ
|
| otherwise = typ
|
||||||
where typ = checkList1 symbs exps (BasicType "Any", NoBounds)
|
where typ = checkExpression symbs ex
|
||||||
|
|
||||||
-- |Auxiliary function for the check list function
|
-- |Auxiliary function for the check list function
|
||||||
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError (Type, Cardinality)
|
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError (Type, Cardinality)
|
||||||
checkList1 _ [] typ = Right typ
|
checkList1 _ [] typ = Right typ
|
||||||
checkList1 symbs (ex : exps) typ
|
checkList1 symbs (ex : exps) typ
|
||||||
| isRight exTyp = exTyp
|
| isLeft exTyp = exTyp
|
||||||
| isRight match = match
|
| not match = Left $ TypeMismatch (typeName $ fst typ) (typeName $ fst (fromRightUnsafe exTyp))
|
||||||
| otherwise = checkList1 symbs exps (fromRightUnsafe match)
|
| otherwise = checkList1 symbs exps (fst typ, crd)
|
||||||
where
|
where
|
||||||
exTyp = checkExpression symbs ex
|
exTyp = checkExpression symbs ex
|
||||||
match = typeMatch typ (fromRightUnsafe exTyp)
|
match = fst typ == fst (fromRightUnsafe exTyp)
|
||||||
|
crd = snd typ .+ snd (fromRightUnsafe exTyp)
|
||||||
|
|
||||||
-- |Checks whether the function that is called is already defined with the same argument types
|
-- |Checks whether the function that is called is already defined with the same argument types
|
||||||
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError (Type, Cardinality)] -> Either TypeCheckError (Type, Cardinality)
|
checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError (Type, Cardinality)] -> Either TypeCheckError (Type, Cardinality)
|
||||||
checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ show (rights args) ++ "]"
|
checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ show (rights args) ++ "]"
|
||||||
checkFunctionCall ((Func n a r):symbolMap) name args
|
checkFunctionCall ((Func n a r):symbolMap) name args
|
||||||
| length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args))
|
| length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args))
|
||||||
| name == n && all isRight (zipWith typeMatch a right) = Right r
|
| name == n && all isRight (zipWith typeIncluded a right) = Right r
|
||||||
| otherwise = checkFunctionCall symbolMap name args
|
| otherwise = checkFunctionCall symbolMap name args
|
||||||
where right = rights 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
|
typeIncluded :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError Bool
|
||||||
|
typeIncluded (t1, c1) (t2, c2)
|
||||||
|
| isSubType t1 t2 && cardinalityIncluded c1 c2 = Right True
|
||||||
|
| isSubType t1 t2 = Left $ CardinalityMismatch c1 c2
|
||||||
|
| otherwise = Left $ TypeMismatch (typeName t1) (typeName t2)
|
||||||
|
|
||||||
-- |Checks whether two types are compatible
|
-- |Checks whether two types are compatible
|
||||||
typeMatch :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError (Type, Cardinality)
|
typeMatch :: Type -> Type -> Either TypeCheckError Type
|
||||||
typeMatch (BasicType "Any", card1) (x, card2)
|
-- |An object matches only with object
|
||||||
| isRight card = Right (x, fromRightUnsafe card)
|
typeMatch (BasicType "Object") _ = Right $ BasicType "Object"
|
||||||
| otherwise = Left $ fromLeftUnsafe card
|
typeMatch _ (BasicType "Object") = Right $ BasicType "Object"
|
||||||
where card = cardinalityIncluded card2 card1
|
-- |Any matches with any type
|
||||||
typeMatch (BasicType "Double", card1) (BasicType "Integer", card2)
|
typeMatch (BasicType "Any") x = Right x
|
||||||
| isRight card = Right (BasicType "Dobule", fromRightUnsafe card)
|
typeMatch x (BasicType "Any") = Right x
|
||||||
| otherwise = Left $ fromLeftUnsafe card
|
-- |Integer can be a double
|
||||||
where card = cardinalityIncluded card2 card1
|
typeMatch (BasicType "Integer") (BasicType "Double") = Right (BasicType "Double")
|
||||||
--typeMatch (s, card1) (BasicType s2, card2)
|
typeMatch (BasicType "Double") (BasicType "Integer") = Right (BasicType "Double")
|
||||||
-- | s == BasicType s2 = case cardinalityIncluded card1 card2 of
|
-- |First check x with all the supertypes of y, then go higher on the supertypes of x and repeat
|
||||||
-- Right card -> Right (s, card)
|
typeMatch x y
|
||||||
-- Left err -> Left err
|
| x == y = Right x
|
||||||
-- | otherwise = Left $ TypeMismatch (typeName s) s2
|
| isRight match = Right $ fromRightUnsafe match
|
||||||
typeMatch (s, card1) (s2, card2)
|
| otherwise = typeMatch (superType x) y
|
||||||
| s == s2 = case cardinalityIncluded card2 card1 of
|
where match = typeMatch x (superType y)
|
||||||
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
|
-- |Checks whether the first argument is a subtype of the second argument
|
||||||
cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError Cardinality
|
isSubType :: Type -> Type -> Bool
|
||||||
cardinalityIncluded x NoBounds = Right x
|
isSubType (BasicType "Integer") (BasicType "Double") = True
|
||||||
cardinalityIncluded NoBounds x = Left $ CardinalityMismatch NoBounds x
|
isSubType _ (BasicType "Any") = True
|
||||||
|
isSubType _ (BasicType "Object") = False
|
||||||
|
isSubType x y
|
||||||
|
| x == y = True
|
||||||
|
| otherwise = isSubType (superType x) y
|
||||||
|
|
||||||
|
-- |Checks whether the first cardinality is included into the second one
|
||||||
|
cardinalityIncluded :: Cardinality -> Cardinality -> Bool
|
||||||
|
cardinalityIncluded _ NoBounds = True
|
||||||
|
cardinalityIncluded NoBounds _ = False
|
||||||
cardinalityIncluded (OneBound x) (OneBound y)
|
cardinalityIncluded (OneBound x) (OneBound y)
|
||||||
| x >= y = Right $ OneBound x
|
| x >= y = True
|
||||||
| otherwise = Left $ CardinalityMismatch (OneBound x) (OneBound y)
|
| otherwise = False
|
||||||
cardinalityIncluded (Bounds (x1, x2)) (OneBound y)
|
cardinalityIncluded (Bounds (x1, _)) (OneBound y)
|
||||||
| x1 >= y = Right $ Bounds (x1, x2)
|
| x1 >= y = True
|
||||||
| otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (OneBound y)
|
| otherwise = False
|
||||||
cardinalityIncluded (OneBound x) (Bounds (y1, y2)) = Left $ CardinalityMismatch (OneBound x) (Bounds (y1, y2))
|
cardinalityIncluded (OneBound _) (Bounds (_, _)) = False
|
||||||
cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
|
cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
|
||||||
| x1 >= y1 && x2 <= y2 = Right $ Bounds (x1, x2)
|
| x1 >= y1 && x2 <= y2 = True
|
||||||
| otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (Bounds (y1, y2))
|
| otherwise = False
|
||||||
|
|
||||||
-- |Looks in the symbol map for the type of a variable
|
-- |Looks in the symbol map for the type of a variable
|
||||||
findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality)
|
findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality)
|
||||||
|
|||||||
@@ -7,11 +7,11 @@ import Semantic.TypeChecker
|
|||||||
import Data.Either
|
import Data.Either
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
|
||||||
-- |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
|
-- |Checks if all the inputs and the output 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 :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] Function
|
||||||
checkFunction (definedTypes, symbols) (MakeFunction name desc inp out ex)
|
checkFunction (definedTypes, symbols) (MakeFunction name desc inp out ex)
|
||||||
| isRight checkedEx && isRight checkedOut && null (lefts checkedIn) =
|
| isRight checkedEx && isRight checkedOut && null (lefts checkedIn) =
|
||||||
case typeMatch (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) (fromRightUnsafe checkedEx) of
|
case typeIncluded (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) (fromRightUnsafe checkedEx) of
|
||||||
Right _ -> Right $ MakeFunction (toLower (head name) : tail name) desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
|
Right _ -> Right $ MakeFunction (toLower (head name) : tail name) desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
|
||||||
Left err -> Left [err]
|
Left err -> Left [err]
|
||||||
| otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx]
|
| otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx]
|
||||||
|
|||||||
@@ -18,20 +18,22 @@ data TypeCheckError =
|
|||||||
-- |Checks whether a data type is valid
|
-- |Checks whether a data type is valid
|
||||||
checkType :: [Type] -> Type -> Either [TypeCheckError] Type
|
checkType :: [Type] -> Type -> Either [TypeCheckError] Type
|
||||||
checkType definedTypes (MakeType name super desc attr)
|
checkType definedTypes (MakeType name super desc attr)
|
||||||
| null (lefts checkedAttr) = case checkSuper definedTypes super of
|
| null (lefts checkedAttr) = case populateSuper definedTypes definedTypes super of
|
||||||
Right superChecked -> Right $ MakeType name superChecked desc (rights checkedAttr)
|
Right superPopulated -> Right $ MakeType name superPopulated desc (rights checkedAttr)
|
||||||
Left err -> Left [err]
|
Left err -> Left [err]
|
||||||
| otherwise = Left $ lefts checkedAttr
|
| otherwise = Left $ lefts checkedAttr
|
||||||
where checkedAttr = checkAttributes definedTypes attr
|
where checkedAttr = checkAttributes definedTypes attr
|
||||||
checkType _ (BasicType b) = Right (BasicType b)
|
checkType _ (BasicType b) = Right (BasicType b)
|
||||||
|
|
||||||
|
populateSuper :: [Type] -> [Type] -> Type -> Either TypeCheckError Type
|
||||||
checkSuper :: [Type] -> Maybe Type -> Either TypeCheckError (Maybe Type)
|
populateSuper _ _ (BasicType "Object") = Right (BasicType "Object")
|
||||||
checkSuper _ Nothing = Right Nothing
|
populateSuper _ _ (BasicType _) = Left $ UndefinedType "Can't extend basic types"
|
||||||
checkSuper definedTypes (Just super) =
|
populateSuper _ [] t = Left $ UndefinedType (typeName t)
|
||||||
case checkAttributeType definedTypes super of
|
populateSuper allTypes (currType : types) (MakeType t super d a)
|
||||||
Right sup -> Right (Just sup)
|
| typeName currType == typeName super = case populateSuper allTypes allTypes currType of
|
||||||
|
Right superChecked -> Right $ MakeType t superChecked d a
|
||||||
Left err -> Left err
|
Left err -> Left err
|
||||||
|
| otherwise = populateSuper allTypes types (MakeType t super d a)
|
||||||
|
|
||||||
-- |Checks whether all the types of the attributes of a data type are already defined
|
-- |Checks whether all the types of the attributes of a data type are already defined
|
||||||
checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute]
|
checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute]
|
||||||
|
|||||||
@@ -40,7 +40,9 @@ spec = do
|
|||||||
|
|
||||||
exps :: [Expression]
|
exps :: [Expression]
|
||||||
exps = [
|
exps = [
|
||||||
|
-- 1
|
||||||
InfixExp "+" (Int "1") (Parens (InfixExp "-" (Int "2") (Int "3"))),
|
InfixExp "+" (Int "1") (Parens (InfixExp "-" (Int "2") (Int "3"))),
|
||||||
|
-- 2
|
||||||
InfixExp "="
|
InfixExp "="
|
||||||
(InfixExp "-"
|
(InfixExp "-"
|
||||||
(InfixExp "-"
|
(InfixExp "-"
|
||||||
@@ -52,17 +54,27 @@ exps = [
|
|||||||
(InfixExp "*" (Variable "g") (Variable "h"))
|
(InfixExp "*" (Variable "g") (Variable "h"))
|
||||||
(InfixExp "*" (Variable "i") (Variable "j")))
|
(InfixExp "*" (Variable "i") (Variable "j")))
|
||||||
(InfixExp "*" (Variable "k") (Variable "l"))),
|
(InfixExp "*" (Variable "k") (Variable "l"))),
|
||||||
|
-- 3
|
||||||
InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (Variable "e"))),
|
InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (Variable "e"))),
|
||||||
|
-- 4
|
||||||
InfixExp "-" (InfixExp "-" (InfixExp "-" (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (Int "3")) (Int "4")) (Int "5")) (Int "6"),
|
InfixExp "-" (InfixExp "-" (InfixExp "-" (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (Int "3")) (Int "4")) (Int "5")) (Int "6"),
|
||||||
|
-- 5
|
||||||
List [Int "1", Int "2", Int "3"],
|
List [Int "1", Int "2", Int "3"],
|
||||||
|
-- 6
|
||||||
List [Int "1", InfixExp "+" (Int "2") (Int "3"), Variable "e"],
|
List [Int "1", InfixExp "+" (Int "2") (Int "3"), Variable "e"],
|
||||||
|
-- 7
|
||||||
Function "Function" [],
|
Function "Function" [],
|
||||||
|
-- 8
|
||||||
Function "Function" [Variable "e"],
|
Function "Function" [Variable "e"],
|
||||||
|
-- 9
|
||||||
Function "Function" [Int "3", InfixExp "+" (Int "3") (Int "2"), Variable "e"],
|
Function "Function" [Int "3", InfixExp "+" (Int "3") (Int "2"), Variable "e"],
|
||||||
|
-- 10
|
||||||
IfElse (Function "Function" [InfixExp "+" (Int "2") (Int "3"), Variable "e"])
|
IfElse (Function "Function" [InfixExp "+" (Int "2") (Int "3"), Variable "e"])
|
||||||
(InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (Variable "e->x"))))
|
(InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (Variable "e->x"))))
|
||||||
(PrefixExp "not" (PostfixExp "exists" (Variable "a"))),
|
(PrefixExp "not" (PostfixExp "exists" (Variable "a"))),
|
||||||
|
-- 11
|
||||||
IfSimple (List [Int "1", Function "Function" [Int "3"]]) (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (InfixExp "*" (Int "3") (InfixExp "^" (Variable "a->b") (Variable "c")))),
|
IfSimple (List [Int "1", Function "Function" [Int "3"]]) (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (InfixExp "*" (Int "3") (InfixExp "^" (Variable "a->b") (Variable "c")))),
|
||||||
|
-- 12
|
||||||
InfixExp "or" (Variable "a") (Variable "b")
|
InfixExp "or" (Variable "a") (Variable "b")
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|||||||
@@ -36,42 +36,42 @@ types :: [Type]
|
|||||||
types = [
|
types = [
|
||||||
MakeType {typeName = "Period",
|
MakeType {typeName = "Period",
|
||||||
typeDescription = Just "description",
|
typeDescription = Just "description",
|
||||||
superType = Nothing,
|
superType = MakeType "Something" (BasicType "Object") Nothing [],
|
||||||
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" Nothing Nothing [], cardinality = Bounds(1, 1),
|
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1),
|
||||||
attributeDescription = Just "A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days."},
|
attributeDescription = Just "A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days."},
|
||||||
MakeTypeAttribute {attributeName = "testMany", attributeType = MakeType "TestType" Nothing Nothing [], cardinality = OneBound 0,
|
MakeTypeAttribute {attributeName = "testMany", attributeType = MakeType "TestType" (BasicType "Object") Nothing [], cardinality = OneBound 0,
|
||||||
attributeDescription = Just "Test many"},
|
attributeDescription = Just "Test many"},
|
||||||
MakeTypeAttribute {attributeName = "testSome", attributeType = MakeType "TestSomeType" Nothing Nothing [], cardinality = OneBound 1,
|
MakeTypeAttribute {attributeName = "testSome", attributeType = MakeType "TestSomeType" (BasicType "Object") Nothing [], cardinality = OneBound 1,
|
||||||
attributeDescription = Just "Test some"},
|
attributeDescription = Just "Test some"},
|
||||||
MakeTypeAttribute {attributeName = "testMaybeOne", attributeType = MakeType "TestZeroOneType" Nothing Nothing [], cardinality = Bounds (0, 1),
|
MakeTypeAttribute {attributeName = "testMaybeOne", attributeType = MakeType "TestZeroOneType" (BasicType "Object") Nothing [], cardinality = Bounds (0, 1),
|
||||||
attributeDescription = Just "Test zero or one"},
|
attributeDescription = Just "Test zero or one"},
|
||||||
MakeTypeAttribute {attributeName = "testAll", attributeType = MakeType "Test" Nothing Nothing [], cardinality = Bounds (2, 15),
|
MakeTypeAttribute {attributeName = "testAll", attributeType = MakeType "Test" (BasicType "Object") Nothing [], cardinality = Bounds (2, 15),
|
||||||
attributeDescription = Just "Test all"}]},
|
attributeDescription = Just "Test all"}]},
|
||||||
|
|
||||||
MakeType {typeName = "TestType",
|
MakeType {typeName = "TestType",
|
||||||
typeDescription = Nothing,
|
typeDescription = Nothing,
|
||||||
superType = Nothing,
|
superType = BasicType "Object",
|
||||||
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" Nothing Nothing [], cardinality = Bounds(1, 1),
|
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1),
|
||||||
attributeDescription = Nothing}]},
|
attributeDescription = Nothing}]},
|
||||||
|
|
||||||
|
|
||||||
MakeType {typeName = "TestSomeType",
|
MakeType {typeName = "TestSomeType",
|
||||||
typeDescription = Just "description",
|
typeDescription = Just "description",
|
||||||
superType = Nothing,
|
superType = BasicType "Object",
|
||||||
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" Nothing Nothing [], cardinality = Bounds(1, 1),
|
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1),
|
||||||
attributeDescription = Just "A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days."}]},
|
attributeDescription = Just "A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days."}]},
|
||||||
|
|
||||||
|
|
||||||
MakeType {typeName = "TestZeroOneType",
|
MakeType {typeName = "TestZeroOneType",
|
||||||
typeDescription = Nothing,
|
typeDescription = Nothing,
|
||||||
superType = Just $ MakeType "Period" Nothing Nothing [],
|
superType = MakeType "Period" (BasicType "Object") Nothing [],
|
||||||
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" Nothing Nothing [], cardinality = Bounds(1, 1),
|
typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1),
|
||||||
attributeDescription = Nothing}]},
|
attributeDescription = Nothing}]},
|
||||||
|
|
||||||
MakeType {typeName = "WrongCardinality", superType = Nothing, typeDescription = Just "description", typeAttributes = []},
|
MakeType {typeName = "WrongCardinality", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []},
|
||||||
|
|
||||||
MakeType {typeName = "WrongCardinality2", superType = Nothing, typeDescription = Just "description", typeAttributes = []},
|
MakeType {typeName = "WrongCardinality2", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []},
|
||||||
|
|
||||||
MakeType {typeName = "MissingType", superType = Nothing, typeDescription = Just "description", typeAttributes = []}
|
MakeType {typeName = "MissingType", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []}
|
||||||
|
|
||||||
]
|
]
|
||||||
Reference in New Issue
Block a user