fixed cardinality of is statements

2026-03-18 21:10:07 +00:00 · 2022-02-17 22:04:55 +01:00
parent 1ebc24140c
commit 8743dc0874
15 changed files with 210 additions and 100 deletions
--- a/src/Model/Header.hs
+++ b/src/Model/Header.hs
@@ -0,0 +1,9 @@
+module Model.Header where
+
+-- |Representation of the information stored in the file header
+data Header = MakeHeader {
+    namespace :: String,
+    headerDescription :: Maybe String, 
+    version :: String,
+    imports :: [String]
+} deriving (Show, Eq)
--- a/src/Model/Type.hs
+++ b/src/Model/Type.hs
@@ -50,6 +50,15 @@ instance Eq Cardinality where
    (==) NoBounds NoBounds = True
    (==) _ _ = False

+-- |Function to create the smallest cardinality that includes two others
+smallestBound  :: Cardinality -> Cardinality -> Cardinality
+smallestBound NoBounds _ = NoBounds
+smallestBound _ NoBounds = NoBounds
+smallestBound (OneBound x) (OneBound y) = OneBound $ min x y
+smallestBound (OneBound x) (Bounds (y, _)) = smallestBound (OneBound x) (OneBound y)
+smallestBound (Bounds (x, _)) (OneBound y) = smallestBound (OneBound x) (OneBound y)
+smallestBound (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (min x1 y1, max x2 y2)
+
 -- |A function used to add two cardinalities    
 addBounds :: Cardinality -> Cardinality -> Cardinality
 addBounds (Bounds (x1, x2)) (Bounds (y1, y2)) = Bounds (x1 + y1, x2 + y2)
@@ -68,4 +77,29 @@ infixl 5 .+
 (.+) = addBounds
  
 typeAndCardinality :: TypeAttribute -> (Type, Cardinality)
-typeAndCardinality (MakeTypeAttribute _ typ crd _) = (typ, crd)
+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 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)
+    | x >= y = True
+    | otherwise = False
+cardinalityIncluded (Bounds (x1, _)) (OneBound y)
+    | x1 >= y = True
+    | otherwise = False
+cardinalityIncluded (OneBound _) (Bounds (_, _)) = False
+cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
+    | x1 >= y1 && x2 <= y2 = True
+    | otherwise = False
--- a/src/Parser/General.hs
+++ b/src/Parser/General.hs
@@ -57,6 +57,9 @@ allowedChars = letterChar <|> digitChar <|> char '_'
 -- |List of restricted names used by Rosetta
 restrictedNames :: [String]
 restrictedNames = [
+    "if",
+    "then",
+    "else",
    "displayName",
    "enum",
    "func",
--- a/src/Parser/Header.hs
+++ b/src/Parser/Header.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser.Header where
+
+import Model.Header
+import Parser.General
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.ParserCombinators.ReadP (many1)
+
+headerParser :: Parser Header
+headerParser = do
+    _ <- lexeme $ string "namespace"
+    name <- namespaceParser
+    desc <- optional descriptionParser
+    _ <- lexeme $ string "version"
+    vers <- between (char '\"') (char '\"') (many (letterChar <|> char '.' <|> char '$' <|> digitChar))
+    imports <- many importParser
+    return $ MakeHeader name desc vers imports
+
+importParser :: Parser String
+importParser = do
+    _ <- lexeme $ string "import"
+    namespaceParser
+
+namespaceParser :: Parser String
+namespaceParser = many (letterChar <|> digitChar <|> char '.' <|> char '*')
--- a/src/PrettyPrinter/Function.hs
+++ b/src/PrettyPrinter/Function.hs
@@ -16,36 +16,47 @@ printFunction f = show $ vcat [printFunctionSignature f, printFunctionBody f, em

 -- |Converts the body of a Function into a haskell valid Doc
 printFunctionBody :: Function -> Doc a
-printFunctionBody (MakeFunction name _ inp _ ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression ex
-printExpression :: Expression -> Doc a
-printExpression (Variable s) = pretty s
-printExpression (Int s) = pretty s
-printExpression (Real s) = pretty s
-printExpression (Boolean s) = pretty s
-printExpression Empty = "empty"
-printExpression (Parens ex) = "(" <> printExpression ex <> ")"
-printExpression (List ex) = list (map printExpression ex)
-printExpression (Function name ex) = pretty name <> tupled (map printExpression ex) 
-printExpression (PrefixExp name ex) = pretty name <+> printExpression ex
-printExpression (PostfixExp "exists" ex) = "isJust" <+> printExpression ex
-printExpression (PostfixExp "is absent" ex) = "isNothing" <+> printExpression ex
-printExpression (PostfixExp "single exists" ex) = "length" <+> printExpression ex <+> "==" <+> "1"
-printExpression (PostfixExp "multiple exists" ex) = "length" <+> printExpression ex <+> ">" <+> "1" 
-printExpression (PostfixExp "count" ex) = "length" <+> printExpression ex
-printExpression (PostfixExp name ex) = pretty name <+> printExpression ex
+printFunctionBody (MakeFunction name _ inp out ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression inp (cardinality out) ex
+printExpression :: [TypeAttribute] -> Cardinality -> Expression -> Doc a
+printExpression inps c (Variable s) = printVariable varC c s
+    where 
+        varC = getVarCardinality inps s
+printExpression inps c (Int s) = printVariable (Bounds (1, 1)) c s
+printExpression inps c (Real s) = printVariable (Bounds (1, 1)) c s
+printExpression inps c (Boolean s) = printVariable (Bounds (1, 1)) c s
+printExpression inps c Empty = "empty"
+printExpression inps c (Parens ex) = "(" <> printExpression inps c ex <> ")"
+printExpression inps c (List ex) = list (map (printExpression inps c) ex)
+printExpression inps c (Function name ex) = pretty name <> tupled (map (printExpression inps c) ex) 
+printExpression inps c (PrefixExp name ex) = pretty name <+> printExpression inps c ex
+printExpression inps c (PostfixExp "exists" ex) = "isJust" <+> printExpression inps c ex
+printExpression inps c (PostfixExp "is absent" ex) = "isNothing" <+> printExpression inps c ex
+printExpression inps c (PostfixExp "single exists" ex) = "length" <+> printExpression inps c ex <+> "==" <+> "1"
+printExpression inps c (PostfixExp "multiple exists" ex) = "length" <+> printExpression inps c ex <+> ">" <+> "1" 
+printExpression inps c (PostfixExp "count" ex) = "length" <+> printExpression inps c ex
+printExpression inps c (PostfixExp name ex) = pretty name <+> printExpression inps c ex
 -- Equality expressions
 -- [a] a all = 
 -- any <>
-printExpression (InfixExp "=" ex1 ex2) = printExpression ex1 <+> "==" <+> printExpression ex2
-printExpression (InfixExp "<>" ex1 ex2) = printExpression ex1 <+> "/=" <+> printExpression ex2
-printExpression (InfixExp "any =" ex1 ex2) = printExpression ex2 <+> "`elem`" <+> printExpression ex1
-printExpression (InfixExp "all <>" ex1 ex2) = printExpression ex2 <+> "`notElem`" <+> printExpression ex1
+printExpression inps c (InfixExp "=" ex1 ex2) = printExpression inps c ex1 <+> "==" <+> printExpression inps c ex2
+printExpression inps c (InfixExp "<>" ex1 ex2) = printExpression inps c ex1 <+> "/=" <+> printExpression inps c ex2
+printExpression inps c (InfixExp "any =" ex1 ex2) = printExpression inps c ex2 <+> "`elem`" <+> printExpression inps c ex1
+printExpression inps c (InfixExp "all <>" ex1 ex2) = printExpression inps c ex2 <+> "`notElem`" <+> printExpression inps c ex1
 --printExpression (InfixExp "all =" ex1 ex2) = "all (Eq)" <+> printExpression ex2 <+> printExpression ex1
-printExpression (InfixExp "and" ex1 ex2) = printExpression ex1 <+> "&&" <+> printExpression ex2
-printExpression (InfixExp "or" ex1 ex2) = printExpression ex1 <+> "||" <+> printExpression ex2
-printExpression (InfixExp name ex1 ex2) = printExpression ex1 <+> pretty name <+> printExpression ex2
-printExpression (IfSimple cond ex) = "if" <+> printExpression cond <+> "then" <+> printExpression ex <+> "else" <+> "Nothing"
-printExpression (IfElse cond ex1 ex2) = "if" <+> printExpression cond <+> "then" <+> printExpression ex1 <+> "else" <+> printExpression ex2
+printExpression inps c (InfixExp "and" ex1 ex2) = printExpression inps c ex1 <+> "&&" <+> printExpression inps c ex2
+printExpression inps c (InfixExp "or" ex1 ex2) = printExpression inps c ex1 <+> "||" <+> printExpression inps c ex2
+printExpression inps c (InfixExp name ex1 ex2) = printExpression inps c ex1 <+> pretty name <+> printExpression inps c ex2
+printExpression inps (Bounds (0, 1)) (IfSimple cond ex) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps (Bounds (0, 1)) ex <+> "else" <+> "Nothing"
+printExpression inps c (IfSimple cond ex) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps c ex <+> "else" <+> "[]"
+printExpression inps c (IfElse cond ex1 ex2) = "if" <+> printExpression inps (Bounds (1, 1)) cond <+> "then" <+> printExpression inps c ex1 <+> "else" <+> printExpression inps c ex2
+
+-- |Converts a variable into a maybe or list depending on necessity
+printVariable :: Cardinality -> Cardinality -> String -> Doc a
+printVariable (Bounds (1, 1)) (Bounds (1, 1)) s = pretty s
+printVariable (Bounds (1, 1)) (Bounds (0, 1)) s = "Just" <+> pretty s
+printVariable (Bounds (0, 1)) (Bounds (0, 1)) s = pretty s
+printVariable (Bounds (1, 1)) _ s = "[" <+> pretty s <+> "]"
+printVariable _ _ s = pretty s

 -- |Converts a list of type attributes to a Doc with a list of variable names
 printVariableNames :: [TypeAttribute] -> Doc a
@@ -58,4 +69,11 @@ printFunctionSignature (MakeFunction name description inputs output _) =

 -- |Zips the signature with the needed characters ('::', '->')
 prettyPrintType :: [Doc x] -> Doc x
-prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
+prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
+
+-- |Gets the cardinality of a variable by name
+getVarCardinality :: [TypeAttribute] -> String -> Cardinality
+getVarCardinality [] _ = error "Variable not a parameter" 
+getVarCardinality (MakeTypeAttribute name _ card _ : inps) varName 
+    | name == varName = card
+    | otherwise = getVarCardinality inps varName
--- a/src/Semantic/ExpressionChecker.hs
+++ b/src/Semantic/ExpressionChecker.hs
@@ -88,9 +88,7 @@ checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap
 checkExpression symbolMap (IfSimple cond ex)
    | isRight condType && isSubType (fst $ fromRightUnsafe condType) (BasicType "Boolean") && snd (fromRightUnsafe condType) == 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
@@ -101,7 +99,6 @@ checkExpression symbolMap (IfSimple cond ex)
 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 || 
-        -- |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
@@ -122,12 +119,13 @@ checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeChec
 checkList1 _ [] typ = Right typ
 checkList1 symbs (ex : exps) typ 
    | isLeft exTyp = exTyp
-    | not match = Left $ TypeMismatch (typeName $ fst typ) (typeName $ fst (fromRightUnsafe exTyp))
-    | otherwise = checkList1 symbs exps (fst typ, crd)
+    | sub = checkList1 symbs exps (fst typ, smallestBound (snd $ fromRightUnsafe exTyp) (snd typ))
+    | sup = checkList1 symbs exps (fst $ fromRightUnsafe exTyp, smallestBound (snd $ fromRightUnsafe exTyp) (snd typ))
+    | otherwise = Left $ TypeMismatch (typeName $ fst typ) (typeName $ fst (fromRightUnsafe exTyp))
    where 
        exTyp = checkExpression symbs ex 
-        match = fst typ == fst (fromRightUnsafe exTyp)
-        crd = snd typ .+ snd (fromRightUnsafe exTyp)
+        sub = isSubType (fst typ) (fst (fromRightUnsafe exTyp))
+        sup = isSubType (fst (fromRightUnsafe  exTyp)) (fst typ)

 -- |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)
@@ -142,11 +140,11 @@ checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name arg

 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
+    | t1 `isSubType` t2 && cardinalityIncluded c1 c2 = Right True
+    | t1 `isSubType` t2 = Left $ CardinalityMismatch c1 c2
    | otherwise = Left $ TypeMismatch (typeName t1) (typeName t2)

-- |Checks whether two types are compatible
+-- |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"
@@ -163,30 +161,6 @@ typeMatch x y
    | isRight match = Right $ fromRightUnsafe match 
    | otherwise = typeMatch (superType x) y
    where match = typeMatch x (superType y)
-    
-- |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 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)
-    | x >= y = True
-    | otherwise = False
-cardinalityIncluded (Bounds (x1, _)) (OneBound y)
-    | x1 >= y = True
-    | otherwise = False
-cardinalityIncluded (OneBound _) (Bounds (_, _)) = False
-cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2))
-    | x1 >= y1 && x2 <= y2 = True
-    | otherwise = False

 -- |Looks in the symbol map for the type of a variable
 findVarType :: String -> [Symbol] -> Either TypeCheckError (Type, Cardinality)
--- a/src/Semantic/FunctionChecker.hs
+++ b/src/Semantic/FunctionChecker.hs
@@ -11,7 +11,7 @@ import Data.Char
 checkFunction :: ([Type], [Symbol]) ->  Function -> Either [TypeCheckError] Function
 checkFunction (definedTypes, symbols) (MakeFunction name desc inp out ex)
    | isRight checkedEx && isRight checkedOut && null (lefts checkedIn) = 
-        case typeIncluded (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) (fromRightUnsafe checkedEx) of
+        case typeIncluded (fromRightUnsafe checkedEx) (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) of
            Right _ -> Right $ MakeFunction (toLower (head name) : tail name) desc (rights checkedIn) (fromRightUnsafe checkedOut) ex
            Left err -> Left [err] 
    | otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx]
--- a/src/Semantic/TypeChecker.hs
+++ b/src/Semantic/TypeChecker.hs
@@ -28,10 +28,10 @@ checkType _ (BasicType b) = Right (BasicType b)
 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 _ [] t = error "WTF" --Left $ UndefinedType (typeName t)
 populateSuper allTypes (currType : types) (MakeType t super d a) 
-    | typeName currType == typeName super = case populateSuper allTypes allTypes currType of
-        Right superChecked -> Right $ MakeType t superChecked d a
+    | typeName currType == t = case populateSuper allTypes allTypes super of
+        Right superChecked -> Right $ MakeType t superChecked (typeDescription currType) (typeAttributes currType)
        Left err -> Left err
    | otherwise = populateSuper allTypes types (MakeType t super d a)