diff --git a/app/Main.hs b/app/Main.hs index 70bd61f..dff6df9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -114,7 +114,7 @@ addNewTypes defined (TypeObject o: os) = case addNewTypes defined os of Left errors -> Left errors Right types -> addDefinedTypes types [o] -addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addNewTypes defined (TypeObject (MakeType name (BasicType "Object") Nothing []) : os) +addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addNewTypes defined (TypeObject (MakeType name (BasicType "Object") Nothing [] []) : os) addNewTypes defined (_ :os) = addNewTypes defined os -- |Parses any supported Rosetta types into a list of RosettaObject diff --git a/resources/Rosetta/test-all.rosetta b/resources/Rosetta/test-all.rosetta index 5c5e95b..4cbbbe7 100644 --- a/resources/Rosetta/test-all.rosetta +++ b/resources/Rosetta/test-all.rosetta @@ -14,6 +14,8 @@ type TestZeroOneType extends Period: type ObservationPrimitive: observationPrimitive int (1..1) + condition important: <"This is an important condition"> + observationPrimitive < 0 func EquityPriceObservation: <"Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class."> inputs: @@ -21,7 +23,6 @@ func EquityPriceObservation: <"Function specification for the observation of an valuationDate ObservationPrimitive (0..1) valuationTime int (0..1) timeType TestType (0..1) - determinationMethod ObservationPrimitive (1..1) output: observation ObservationPrimitive (0..1) @@ -38,6 +39,8 @@ func Something: <"asd"> func SomethingElse: <"dsa"> inputs: + num1 int (1..1) + num2 int (0..1) valuationTime ObservationPrimitive (1..1) output: valuation ObservationPrimitive (0..1) diff --git a/resources/Rosetta/test-function.rosetta b/resources/Rosetta/test-function.rosetta new file mode 100644 index 0000000..0370380 --- /dev/null +++ b/resources/Rosetta/test-function.rosetta @@ -0,0 +1,36 @@ +namespace test.all : <"Something"> +version "${version.ok}" + +type ObservationPrimitive: + observationPrimitive int (1..1) + condition important: <"This is an important condition"> + observationPrimitive < 0 + + +func UsingFunctions: <"This function will use the other functions"> + inputs: + val ObservationPrimitive (1..1) + bol boolean (1..1) + output: + valuation ObservationPrimitive(0..*) + + assign-output: if bol then Something (bol, val) else SomethingElse (1, 2, val) + +func Something: <"asd"> + inputs: + equity1 boolean (1..1) + valuationTime ObservationPrimitive (1..1) + output: + valuation ObservationPrimitive (0..*) + + assign-output: if True and False then valuationTime + +func SomethingElse: <"dsa"> + inputs: + num1 int (1..1) + num2 int (0..1) + valuationTime ObservationPrimitive (1..1) + output: + valuation ObservationPrimitive (0..1) + + assign-output: if True and False then valuationTime \ No newline at end of file diff --git a/src/Model/Function.hs b/src/Model/Function.hs index 1884bc5..bba703e 100644 --- a/src/Model/Function.hs +++ b/src/Model/Function.hs @@ -1,6 +1,6 @@ module Model.Function where -import Model.Type (TypeAttribute) +import Model.Type (TypeAttribute, Expression) -- |The representation of a Rosetta function type data Function = @@ -11,20 +11,4 @@ data Function = outputParameter :: TypeAttribute, assignment :: Expression } - deriving (Show) - --- |The representation of an expression -data Expression = Variable String - | Int String - | Real String - | Boolean String - | Empty - | Parens Expression - | List [Expression] - | Function String [Expression] - | PrefixExp String Expression - | PostfixExp String Expression - | InfixExp String Expression Expression - | IfSimple Expression Expression - | IfElse Expression Expression Expression - deriving (Eq, Show) \ No newline at end of file + deriving (Show) \ No newline at end of file diff --git a/src/Model/Type.hs b/src/Model/Type.hs index dbc465b..9fd117b 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -5,7 +5,8 @@ data Type = MakeType { typeName :: String, superType :: Type, typeDescription :: Maybe String, - typeAttributes :: [TypeAttribute] + typeAttributes :: [TypeAttribute], + conditions :: [Condition] } | BasicType { typeName :: String @@ -13,7 +14,7 @@ data Type = MakeType { deriving (Show) instance Eq Type where - (==) (MakeType name _ _ _) (MakeType name2 _ _ _) + (==) (MakeType name _ _ _ _) (MakeType name2 _ _ _ _) | name == name2 = True | otherwise = False (==) (BasicType name) (BasicType name2) @@ -21,6 +22,27 @@ instance Eq Type where | otherwise = False (==) _ _ = False +data Condition = MakeCondition { + conditionName :: String, + conditionDescription :: Maybe String, + expressionExpression :: Expression +} deriving (Show) + +-- |The representation of an expression +data Expression = Variable String + | Int String + | Real String + | Boolean String + | Empty + | Parens Expression + | List [Expression] + | Function String [Expression] + | PrefixExp String Expression + | PostfixExp String Expression + | InfixExp String Expression Expression + | IfSimple Expression Expression + | IfElse Expression Expression Expression + deriving (Eq, Show) -- |The representation of an attribute of a data type data TypeAttribute = MakeTypeAttribute { @@ -81,10 +103,13 @@ typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd) -- |Checks whether the first argument is a subtype of the second argument isSubType :: Type -> Type -> Bool isSubType (BasicType "Integer") (BasicType "Double") = True -isSubType _ (BasicType "Any") = True -isSubType _ (BasicType "Object") = False +isSubType _ (BasicType "Object") = True +isSubType _ (BasicType "Any") = False +isSubType (BasicType x) y + | x == typeName y = True + | otherwise = False isSubType x y - | x == y = True + | typeName x == typeName y = True | otherwise = isSubType (superType x) y -- |Checks whether the first cardinality is included into the second one @@ -100,4 +125,11 @@ cardinalityIncluded (Bounds (x1, _)) (OneBound y) cardinalityIncluded (OneBound _) (Bounds (_, _)) = False cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2)) | x1 >= y1 && x2 <= y2 = True - | otherwise = False \ No newline at end of file + | otherwise = False + +toHaskell :: Type -> Type +toHaskell a + | typeName a == "int" = BasicType "Integer" + | typeName a == "boolean" = BasicType "Boolean" + | typeName a == "real" = BasicType "Double" + | otherwise = a \ No newline at end of file diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 60ada40..1ed606d 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -4,6 +4,7 @@ module Parser.Expression where import Parser.General import Model.Function +import Model.Type (Expression (..)) import qualified Data.Text as Text import Text.Megaparsec import Text.Megaparsec.Char diff --git a/src/Parser/Function.hs b/src/Parser/Function.hs index 347eaaa..6cf5b1d 100644 --- a/src/Parser/Function.hs +++ b/src/Parser/Function.hs @@ -52,5 +52,5 @@ attributeParser = typ <- try (pascalNameParser <|> camelNameParser) crd <- cardinalityParser desc <- optional descriptionParser - return $ MakeTypeAttribute nam (MakeType typ (BasicType "Object") Nothing []) crd desc + return $ MakeTypeAttribute nam (MakeType typ (BasicType "Object") Nothing [] []) crd desc \ No newline at end of file diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index fe3198c..583133b 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -7,25 +7,30 @@ import Text.Megaparsec.Char import Text.Megaparsec import Data.Maybe import Parser.General +import Parser.Expression (expressionParser) -- |Parses a type declaration statement in Rosetta into an Type typeParser :: Parser Type typeParser = do tName <- try typeNameParser - tSuper <- optional superTypeParser + tSuper <- superTypeParser _ <- lexeme $ char ':' tDescription <- optional descriptionParser tAttributes <- many $ try typeAttributeParser - if isJust tSuper then return (MakeType tName (fromJust tSuper) tDescription tAttributes) else return (MakeType tName (BasicType "Object") tDescription tAttributes) + tConditions <- many $ try conditionParser + return (MakeType tName tSuper tDescription tAttributes tConditions) -- |Parses the super class declaration statement in Rosetta into an Type superTypeParser :: Parser Type superTypeParser = do - _ <- lexeme $ string "extends" - name <- pascalNameParser - return $ MakeType name (BasicType "Object") Nothing [] + exists <- lexeme $ optional $ string "extends" + case exists of + Nothing -> return $ BasicType "Object" + Just _ -> do + name <- pascalNameParser + return $ MakeType name (BasicType "Object") Nothing [] [] -- |Parses a declared type attribute in Rosetta into a TypeAttribute typeAttributeParser :: Parser TypeAttribute @@ -35,13 +40,20 @@ typeAttributeParser = aType <- try nameParser card <- cardinalityParser desc <- optional descriptionParser - return (MakeTypeAttribute aName (MakeType aType (BasicType "Object") 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 cardinalityParser :: Parser Cardinality -cardinalityParser = - do - try parseBounded <|> try parseSemiBounded <|> try parseUnbounded +cardinalityParser = try parseBounded <|> try parseSemiBounded <|> try parseUnbounded + +-- |Parser the condition of a type attribute in Rosetta into a Condition +conditionParser :: Parser Condition +conditionParser = do + _ <- lexeme $ string "condition" + name <- lexeme camelNameParser + _ <- lexeme $ char ':' + description <- optional descriptionParser + MakeCondition name description <$> expressionParser -- |Parses a bounded cardinality statement in Rosetta into a Cardinality parseBounded :: Parser Cardinality diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index 103ad54..c017c2b 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -9,15 +9,15 @@ import Utils.Utils -- |Converts an EnumType into a haskell valid String printType :: Type -> String -printType (MakeType name (MakeType super _ _ _) description attributes) = printType (MakeType name (BasicType "Object") description (superToAttribute name super:attributes)) -printType (MakeType name (BasicType "Object") description attributes) = - show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes name attributes), "}", "", emptyDoc]) -printType (MakeType _ (BasicType _) _ _) = error "Can't extend basic types" +printType (MakeType name (MakeType super _ _ _ _) description attributes conditions) = printType (MakeType name (BasicType "Object") description (superToAttribute super:attributes) conditions) +printType (MakeType name (BasicType "Object") description attributes conditions) = + show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes name attributes ++ map printCondition conditions), "}", emptyDoc, emptyDoc]) +printType (MakeType _ (BasicType _) _ _ _) = error "Can't extend basic types" printType (BasicType name) = show $ pretty name -- |Creates an attribute that accesses the super type -superToAttribute :: String -> String -> TypeAttribute -superToAttribute name typ = MakeTypeAttribute ("super" ++ name) (MakeType typ (BasicType "Object") Nothing []) (Bounds (1, 1)) (Just "Pointer to super class") +superToAttribute :: String -> TypeAttribute +superToAttribute typ = MakeTypeAttribute "super" (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 printAttributes :: String -> [TypeAttribute] -> [Doc a] @@ -38,4 +38,7 @@ printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _) | x == 1 && y == 1 = pretty (typeName typ) | otherwise = "[" <> pretty (typeName typ) <> "]" printCardinality (MakeTypeAttribute _ typ NoBounds _) = "[" <> pretty (typeName typ) <> "]" -printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]" \ No newline at end of file +printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]" + +printCondition :: Condition -> Doc a +printCondition (MakeCondition name desc e) = printDescription desc ("--" <+> pretty name <+> pretty (show e)) \ No newline at end of file diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index af3f7dc..9d66773 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -81,7 +81,7 @@ 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 crd _) : vars) = Var name typ crd : addVariables s vars +addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskell typ) crd : addVariables s vars -- |Checks the type of a given expression checkExpression :: [Symbol] -> Expression -> Either TypeCheckError (Type, Cardinality) @@ -109,14 +109,13 @@ checkExpression symbolMap (IfSimple cond 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 checkExpression symbolMap (IfElse cond ex1 ex2) - | isLeft condType || isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1) = Left $ IfConditionNotBoolean $ show cond - | isLeft ex1Type || isLeft ex2Type || - isLeft (typeMatch (fst $ fromRightUnsafe ex1Type) (fst $ fromRightUnsafe ex2Type)) || - snd (fromRightUnsafe ex1Type) /= snd (fromRightUnsafe ex2Type) = Left $ IfExpressionsDifferentTypes (show ex1) (show ex2) - | otherwise = ex1Type + | isLeft condType || not (isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == Bounds (1, 1)) = Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show condType + | otherwise = case checkExpression symbolMap ex1 of + Left err -> Left $ ErrorInsideFunction $ show err + Right ex1Type -> case checkExpression symbolMap ex2 of + Left err -> Left $ ErrorInsideFunction $ show err + Right ex2Type -> Right (typeMatch (fst ex1Type) (fst ex2Type), smallestBound (snd ex1Type) (snd ex2Type)) 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, Cardinality) @@ -144,7 +143,7 @@ checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError (Type, Cardina checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ show (rights args) ++ "]" checkFunctionCall ((Func n a r):symbolMap) name args | length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args)) - | name == n && all isRight (zipWith typeIncluded a right) = Right r + | name == n && all isRight (zipWith typeIncluded right a) = Right r | otherwise = checkFunctionCall symbolMap name args where right = rights args @@ -156,23 +155,21 @@ typeIncluded (t1, c1) (t2, c2) | t1 `isSubType` t2 = Left $ CardinalityMismatch c1 c2 | otherwise = Left $ TypeMismatch (typeName t1) (typeName t2) --- |Checks whether two types are compatible (i.e. they have a common super type) -typeMatch :: Type -> Type -> Either TypeCheckError Type --- |An object matches only with object -typeMatch (BasicType "Object") _ = Right $ BasicType "Object" -typeMatch _ (BasicType "Object") = Right $ BasicType "Object" +-- |Finds the most specific super type of the two types +typeMatch :: Type -> Type -> Type -- |Any matches with any type -typeMatch (BasicType "Any") x = Right x -typeMatch x (BasicType "Any") = Right x +typeMatch (BasicType "Any") x = x +typeMatch x (BasicType "Any") = x -- |Integer can be a double -typeMatch (BasicType "Integer") (BasicType "Double") = Right (BasicType "Double") -typeMatch (BasicType "Double") (BasicType "Integer") = Right (BasicType "Double") +-- typeMatch (BasicType "Integer") (BasicType "Double") = BasicType "Double" +-- typeMatch (BasicType "Double") (BasicType "Integer") = BasicType "Double" +typeMatch x (BasicType y) + | x `isSubType` BasicType y = x + | otherwise = BasicType "Object" -- |First check x with all the supertypes of y, then go higher on the supertypes of x and repeat -typeMatch x y - | x == y = Right x - | isRight match = Right $ fromRightUnsafe match - | otherwise = typeMatch (superType x) y - where match = typeMatch x (superType y) +typeMatch x y + | x `isSubType` y = x + | otherwise = typeMatch x (superType y) -- |Looks in the symbol map for the type of a variable findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality) diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index d4ca535..63474d0 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -20,9 +20,9 @@ data TypeCheckError = -- |Checks whether a data type is valid checkType :: [Type] -> Type -> Either [TypeCheckError] Type -checkType definedTypes (MakeType name super desc attr) +checkType definedTypes (MakeType name super desc attr cond) | null (lefts checkedAttr) = case populateSuper definedTypes definedTypes super of - Right superPopulated -> Right $ MakeType name superPopulated desc (rights checkedAttr) + Right superPopulated -> Right $ MakeType name superPopulated desc (rights checkedAttr) cond Left err -> Left [err] | otherwise = Left $ lefts checkedAttr where checkedAttr = checkAttributes definedTypes attr @@ -32,11 +32,11 @@ populateSuper :: [Type] -> [Type] -> Type -> Either TypeCheckError Type populateSuper _ _ (BasicType "Object") = Right (BasicType "Object") populateSuper _ _ (BasicType _) = Left $ UndefinedType "Can't extend basic types" populateSuper _ [] t = Left $ UndefinedType (typeName t) -populateSuper allTypes (currType : types) (MakeType t super d a) +populateSuper allTypes (currType : types) (MakeType t super d a c) | typeName currType == t = case populateSuper allTypes allTypes super of - Right superChecked -> Right $ MakeType t superChecked (typeDescription currType) (typeAttributes currType) + Right superChecked -> Right $ MakeType t superChecked (typeDescription currType) (typeAttributes currType) c Left err -> Left err - | otherwise = populateSuper allTypes types (MakeType t super d a) + | otherwise = populateSuper allTypes types (MakeType t super d a c) -- |Checks whether all the types of the attributes of a data type are already defined checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute] @@ -48,11 +48,11 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) -- |Checks whether a type is predefined or in the symbol table checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type -checkAttributeType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer" -checkAttributeType _ (MakeType "string" _ _ _) = Right $ BasicType "String" -checkAttributeType _ (MakeType "number" _ _ _) = Right $ BasicType "Double" -checkAttributeType _ (MakeType "boolean" _ _ _) = Right $ BasicType "Bool" -checkAttributeType _ (MakeType "time" _ _ _) = Right $ BasicType "Time" +checkAttributeType _ (MakeType "int" _ _ _ _) = Right $ BasicType "Integer" +checkAttributeType _ (MakeType "string" _ _ _ _) = Right $ BasicType "String" +checkAttributeType _ (MakeType "number" _ _ _ _) = Right $ BasicType "Double" +checkAttributeType _ (MakeType "boolean" _ _ _ _) = Right $ BasicType "Bool" +checkAttributeType _ (MakeType "time" _ _ _ _) = Right $ BasicType "Time" checkAttributeType definedTypes name | name `elem` definedTypes = Right name | otherwise = Left $ UndefinedType (typeName name)