Fixed subtyping

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

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)

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

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 = 
@@ -12,19 +12,3 @@ data Function =
         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)

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 
@@ -101,3 +126,10 @@ cardinalityIncluded (OneBound _) (Bounds (_, _)) = False
 cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
     | x1 >= y1 && x2 <= y2 = True
     | otherwise = False
+
+toHaskell :: Type -> Type
+toHaskell a
+    | typeName a == "int" = BasicType "Integer"
+    | typeName a == "boolean" = BasicType "Boolean"
+    | typeName a == "real" = BasicType "Double"
+    | otherwise = a

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

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
         

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

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]
@@ -39,3 +39,6 @@ printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _)
     | otherwise = "[" <> pretty (typeName typ) <> "]"
 printCardinality (MakeTypeAttribute _ typ NoBounds _) = "[" <> pretty (typeName typ) <> "]"
 printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]"
+
+printCondition :: Condition -> Doc a
+printCondition (MakeCondition name desc e) = printDescription desc ("--" <+> pretty name <+> pretty (show e))

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)
+    | 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)

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)