From 464ef29caa41b0c9a2f74fa572530dc380f42a81 Mon Sep 17 00:00:00 2001 From: macocianradu Date: Sun, 31 Oct 2021 21:36:55 +0100 Subject: [PATCH] refactored type to add supertype changed typechecker to have multiple errors and lower types can be used as super types --- app/Main.hs | 30 ++++--- src/Model/Type.hs | 16 +++- src/Parser/Enum.hs | 10 +-- src/Parser/Function.hs | 6 +- src/Parser/Type.hs | 26 ++++-- src/PrettyPrinter/Type.hs | 14 ++- src/Semantic/TypeChecker.hs | 168 +++++++++++++++++++++--------------- src/TestFiles/typeTest.hs | 8 +- 8 files changed, 167 insertions(+), 111 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7d3dee6..313599b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -66,36 +66,42 @@ testFunc = do writeFile "src/TestFiles/functionTest.hs" (show $ printFunctionSignature fun) testExpTypeChecker :: IO () -testExpTypeChecker = print $ mapExpsToTypes expressions +testExpTypeChecker = putStrLn $ printOnOneLine $ mapExpsToTypes expressions mapExpsToTypes :: [String] -> [(String, String)] mapExpsToTypes [] = [] mapExpsToTypes (expr: exps) = do case parse expressionParser "" (Text.pack expr) of Left errorBundle -> error (errorBundlePretty errorBundle) - Right ex -> (show ex, checkExpression defaultMap ex) :mapExpsToTypes exps + Right ex -> (show ex, show $ checkExpression defaultMap ex) :mapExpsToTypes exps + +printOnOneLine :: [(String, String)] -> String +printOnOneLine [] = "" +printOnOneLine ((ex, typ): exps) = "(" ++ ex ++ "," ++ typ ++ ")\n" ++ printOnOneLine exps expressions :: [String] expressions = [ --Or Good "True or False", --- --Or Bad --- "1 or False", + --Or Bad + "1 or False", --And Good "False and False", --- --And Bad --- "1 and 2", + --And Bad + "1 and 2", --Exists Good "a exists", --Plus Good "1.2 + 2.3", --- --Plus Bad --- "True + 2", + "1 + 2.3", + "1 + 2", + --Plus Bad + "True + 2", --If Good "if True then 2 else 3", --- --If Bad Cond --- "if 2 then True else False", + --If Bad Cond + "if 2 then True else False", --If Bad exps --- "if True then 2 else False" - "if True or False then 24 + 15 else 55 + 98 + 35 + 34" + "if True then 2 else False", + "if True or False then 24 + 15 else 55 + 98 + 35 + 34" ] \ No newline at end of file diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 388d14a..096b5ed 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -4,18 +4,32 @@ import Data.Time.LocalTime() data Type = MakeType { typeName :: String, + superType :: Maybe Type, typeDescription :: Maybe String, typeAttributes :: [TypeAttribute] } + | BasicType { + typeName :: String + } deriving (Show) +instance Eq Type where + (==) (MakeType name _ _ _) (MakeType name2 _ _ _) + | name == name2 = True + | otherwise = False + (==) (BasicType name) (BasicType name2) + | name == name2 = True + | otherwise = False + (==) _ _ = False + data TypeAttribute = MakeTypeAttribute { attributeName :: String, - attributeType :: String, + attributeType :: Type, cardinality :: Cardinality, attributeDescription :: Maybe String } deriving (Show) +--TODO use bounded class data Cardinality = ZeroOrOne | ExactlyOne diff --git a/src/Parser/Enum.hs b/src/Parser/Enum.hs index 7552a3c..e1256c3 100755 --- a/src/Parser/Enum.hs +++ b/src/Parser/Enum.hs @@ -12,18 +12,18 @@ enumParser :: Parser EnumType enumParser = do eName <- enumNameParser - eDescription <- descriptionParser + eDescription <- optional descriptionParser values <- many enumValueParser - return (MakeEnum eName (Just eDescription) values) + return (MakeEnum eName eDescription values) --parseTest enumValueParser "D displayName \"day\" <\"Day\">" enumValueParser :: Parser EnumValue enumValueParser = do vName <- nameParser - dName <- enumValueDisplayNameParser - vDescription <- descriptionParser - return (MakeEnumValue vName (Just vDescription) (Just dName)) + dName <- optional enumValueDisplayNameParser + vDescription <- optional descriptionParser + return (MakeEnumValue vName vDescription dName) enumValueDisplayNameParser :: Parser String enumValueDisplayNameParser = diff --git a/src/Parser/Function.hs b/src/Parser/Function.hs index 105d89e..651006c 100644 --- a/src/Parser/Function.hs +++ b/src/Parser/Function.hs @@ -16,11 +16,11 @@ functionParser = _ <- lexeme $ string "func" fName <- pascalNameParser _ <- lexeme $ char ':' - fDescription <- descriptionParser + fDescription <- optional descriptionParser fInput <- inputAttributesParser fOutput <- outputAttributeParser fAssignments <- many assignmentParser - return (MakeFunction fName (Just fDescription) fInput fOutput fAssignments) + return (MakeFunction fName fDescription fInput fOutput fAssignments) assignmentParser :: Parser (Expression, Expression) assignmentParser = @@ -50,5 +50,5 @@ attributeParser = typ <- pascalNameParser <|> camelNameParser crd <- cardinalityParser desc <- optional descriptionParser - return $ MakeTypeAttribute nam typ crd desc + return $ MakeTypeAttribute nam (MakeType typ Nothing Nothing []) crd desc \ No newline at end of file diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index 38e4d79..fad0b6d 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -12,9 +12,18 @@ typeParser :: Parser Type typeParser = do tName <- typeNameParser - tDescription <- descriptionParser + tSuper <- optional superTypeParser + _ <- lexeme $ char ':' + tDescription <- optional descriptionParser tAttributes <- many $ try typeAttributeParser - return (MakeType tName (Just tDescription) tAttributes) + return (MakeType tName tSuper tDescription tAttributes) + +superTypeParser :: Parser Type +superTypeParser = + do + _ <- lexeme $ string "extending" + name <- pascalNameParser + return $ MakeType name Nothing Nothing [] typeAttributeParser :: Parser TypeAttribute typeAttributeParser = @@ -23,7 +32,7 @@ typeAttributeParser = aType <- nameParser card <- cardinalityParser desc <- optional descriptionParser - return (MakeTypeAttribute aName aType card desc) + return (MakeTypeAttribute aName (MakeType aType Nothing Nothing []) card desc) cardinalityParser :: Parser Cardinality cardinalityParser = @@ -61,23 +70,22 @@ typeNameParser :: Parser String typeNameParser = do _ <- lexeme $ string "type" - name <- pascalNameParser - _ <- lexeme $ char ':' - return name - + pascalNameParser + periodType :: Type periodType = MakeType "Period" + Nothing (Just "A class to define recurring periods or time offsets") [MakeTypeAttribute "periodMultiplier" - "Integer" + (BasicType "Integer") ExactlyOne (Just "A time period multiplier"), MakeTypeAttribute "period" - "periodEnum" + (MakeType "PeriodEnum" Nothing Nothing []) ExactlyOne (Just "A time period") ] \ No newline at end of file diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index 1518bbe..b9d5fe8 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -7,19 +7,17 @@ import PrettyPrinter.General import Model.Type printType :: Type -> String -printType (MakeType name description attributes) = +printType (MakeType name _ description attributes) = show $ printDescription description (vcat [nest 4 $ vcat("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": map printAttribute attributes), "}", ""]) +printType (BasicType name) = show $ pretty name -printTypeName :: Type -> String -printTypeName (MakeType name _ _) = name - printAttribute :: TypeAttribute -> Doc a printAttribute (MakeTypeAttribute name typ crd description) = printDescription description (pretty name <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd description)) printCardinality :: TypeAttribute -> Doc a -printCardinality (MakeTypeAttribute _ typ ExactlyOne _) = pretty typ -printCardinality (MakeTypeAttribute _ typ OneOrMore _) = "[" <> pretty typ <> "]" -printCardinality (MakeTypeAttribute _ typ ZeroOrMore _) = "[" <> pretty typ <> "]" -printCardinality (MakeTypeAttribute _ typ ZeroOrOne _) = "Maybe" <+> pretty typ \ No newline at end of file +printCardinality (MakeTypeAttribute _ typ ExactlyOne _) = pretty (typeName typ) +printCardinality (MakeTypeAttribute _ typ OneOrMore _) = "[" <> pretty (typeName typ) <> "]" +printCardinality (MakeTypeAttribute _ typ ZeroOrMore _) = "[" <> pretty (typeName typ) <> "]" +printCardinality (MakeTypeAttribute _ typ ZeroOrOne _) = "Maybe" <+> pretty (typeName typ) \ No newline at end of file diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index 21888cb..842a77a 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -2,70 +2,83 @@ module Semantic.TypeChecker where import Model.Type import Model.Function +import Data.Either +import Data.Maybe + +data TypeCheckError = + UndefinedType String + | IfConditionNotBoolean + | IfExpressionsDifferentTypes + | UndefinedFunction String + | ErrorInsideFunction + | UndefinedVariable String + | TypeMismatch String String + deriving (Show) data Symbol = Var{ varName :: String, - declaredType :: String + declaredType :: Type } | Func { funcName :: String, - argsType :: [String], - returnType :: String + argsType :: [Type], + returnType :: Type } defaultMap :: [Symbol] defaultMap = [ - Func "or" ["Boolean", "Boolean"] "Boolean", - Func "and" ["Boolean", "Boolean"] "Boolean", - Func "exists" ["Any"] "Boolean", - Func "is absent" ["Any"] "Boolean", - Func "single exists" ["Any"] "Boolean", - Func "multiple exists" ["Any"] "Boolean", - Func "contains" ["Any", "Any"] "Boolean", - Func "disjoint" ["Any", "Any"] "Boolean", + 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 "=" ["Any", "Any"] "Boolean", - Func ">=" ["Any", "Any"] "Boolean", - Func "<=" ["Any", "Any"] "Boolean", - Func "<>" ["Any", "Any"] "Boolean", - Func ">" ["Any", "Any"] "Boolean", - Func "<" ["Any", "Any"] "Boolean", - Func "all =" ["Any", "Any"] "Boolean", - Func "all <>" ["Any", "Any"] "Boolean", - Func "any =" ["Any", "Any"] "Boolean", - Func "any <>" ["Any", "Any"] "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 "<" [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 "+" ["Integer", "Integer"] "Integer", - Func "+" ["Double", "Double"] "Double", - Func "-" ["Integer", "Integer"] "Integer", - Func "-" ["Double", "Double"] "Double", - Func "*" ["Integer", "Integer"] "Integer", - Func "*" ["Double", "Double"] "Double", - Func "/" ["Integer", "Integer"] "Integer", - Func "/" ["Double", "Double"] "Double", - Func "^" ["Integer", "Integer"] "Integer", - Func "^" ["Double", "Double"] "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", BasicType "Integer"] (BasicType "Integer"), + Func "^" [BasicType "Double", BasicType "Double"] (BasicType "Double"), - Func "count" ["Any"] "Integer" + Func "count" [BasicType "Any"] (BasicType "Integer") ] -checkAttributes :: [String] -> [TypeAttribute] -> [String] +checkAttributes :: [Type] -> [TypeAttribute] -> [Either Type TypeCheckError] checkAttributes _ [] = [] checkAttributes definedTypes ((MakeTypeAttribute _ name _ _):as) = checkType definedTypes name : checkAttributes definedTypes as -checkType :: [String] -> String -> String -checkType _ "int" = "Integer" -checkType _ "string" = "String" -checkType _ "boolean" = "Bool" -checkType _ "time" = "Time" -checkType _ "number" = "Double" +checkType :: [Type] -> Type -> Either Type TypeCheckError +checkType _ (MakeType "int" _ _ _) = Left $ BasicType "Integer" +checkType _ (MakeType "string" _ _ _) = Left $ BasicType "String" +checkType _ (MakeType "number" _ _ _) = Left $ BasicType "Double" +checkType _ (MakeType "boolean" _ _ _) = Left $ BasicType "Bool" +checkType _ (MakeType "time" _ _ _) = Left $ BasicType "Time" checkType definedTypes name - | name `elem` definedTypes = name - | otherwise = error "Undefined type: " ++ name + | name `elem` definedTypes = Left name + | otherwise = Right $ UndefinedType (typeName name) -addDefinedTypes :: [String] -> [Type] -> [String] +addDefinedTypes :: [Type] -> [Type] -> [Type] addDefinedTypes l [] = l -addDefinedTypes l ((MakeType name _ _):ts) = name : addDefinedTypes l ts +addDefinedTypes l (BasicType _ : ts) = addDefinedTypes l ts +addDefinedTypes l (t:ts) = t : addDefinedTypes l ts --Variable String -- | Int String @@ -81,46 +94,65 @@ addDefinedTypes l ((MakeType name _ _):ts) = name : addDefinedTypes l ts -- | IfSimple Expression Expression -- | IfElse Expression Expression Expression -checkExpression :: [Symbol] -> Expression -> String -checkExpression symbolMap (Variable var) = findVar var symbolMap -checkExpression _ (Int _) = "Integer" -checkExpression _ (Real _) = "Double" -checkExpression _ (Boolean _) = "Boolean" -checkExpression _ Empty = "Empty" +checkExpression :: [Symbol] -> Expression -> Either Type TypeCheckError +checkExpression symbolMap (Variable var) = findVarType var symbolMap +checkExpression _ (Int _) = Left $ BasicType "Integer" +checkExpression _ (Real _) = Left $ BasicType "Double" +checkExpression _ (Boolean _) = Left $ BasicType "Boolean" +checkExpression _ Empty = Left $ BasicType "Empty" checkExpression symbolMap (Parens ex) = checkExpression symbolMap ex -checkExpression _ (List _) = "List" +--TODO check list has same type +checkExpression _ (List _) = Left $ BasicType "List" checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps) checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2]) checkExpression symbolMap (IfSimple cond ex) - | condType == "Boolean" = checkExpression symbolMap ex - | otherwise = error "Expected boolean condition in if statement" + | isLeft condType && isLeft (typeMatch (fromLeftUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex + | otherwise = Right IfConditionNotBoolean where condType = checkExpression symbolMap cond checkExpression symbolMap (IfElse cond ex1 ex2) - | condType /= "Boolean" = error "Expected boolean condition in if statement" - | not (typeMatch ex1Type ex2Type) = error "Types of then and else branches don't match" + | isRight condType || isRight (typeMatch (fromLeftUnsafe condType) (BasicType "Boolean")) = Right IfConditionNotBoolean + | isRight ex1Type || isRight ex2Type || isRight (typeMatch (fromLeftUnsafe ex1Type) (fromLeftUnsafe ex2Type)) = Right IfExpressionsDifferentTypes | otherwise = ex1Type where condType = checkExpression symbolMap cond ex1Type = checkExpression symbolMap ex1 ex2Type = checkExpression symbolMap ex2 - -checkFunctionCall :: [Symbol] -> String -> [String] -> String -checkFunctionCall [] fun args = error "Undefined function: " ++ fun ++ concat args +checkFunctionCall :: [Symbol] -> String -> [Either Type TypeCheckError] -> Either Type TypeCheckError +checkFunctionCall [] fun args = Right $ UndefinedFunction $ "Undefined function: " ++ fun ++ concatMap typeName (lefts args) checkFunctionCall ((Func n a r):symbolMap) name args - | name == n && and (zipWith typeMatch a args) = r + | length left /= length args = Right ErrorInsideFunction + | name == n && all isLeft (zipWith typeMatch a left) = Left r | otherwise = checkFunctionCall symbolMap name args + where left = lefts args checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args -typeMatch :: String -> String -> Bool -typeMatch "Any" _ = True -typeMatch _ "Any" = True -typeMatch s s2 = s == s2 +--Try to match 2nd type to first type +typeMatch :: Type -> Type -> Either Type TypeCheckError +typeMatch (BasicType "Any") x = Left x +typeMatch (BasicType "Double") (BasicType "Integer") = Left $ BasicType "Dobule" +typeMatch s (BasicType s2) + | s == BasicType s2 = Left s + | otherwise = Right $ TypeMismatch (typeName s) s2 +typeMatch s s2 + | s == s2 = Left s + | isJust $ superType s2 = typeMatch s (fromJust $ superType s2) + | otherwise = Right $ TypeMismatch (typeName s) (typeName s2) -findVar :: String -> [Symbol] -> String -findVar var [] = error "Undefined variable " ++ var -findVar x ((Var name typ):symbols) - | x == name = typ - | otherwise = findVar x symbols -findVar x (_:symbols) = findVar x symbols \ No newline at end of file +findVarType :: String -> [Symbol] -> Either Type TypeCheckError +findVarType var [] = Right $ UndefinedVariable var +findVarType x ((Var name typ):symbols) + | x == name = Left typ + | otherwise = findVarType x symbols +findVarType x (_:symbols) = findVarType x symbols + +fromRightUnsafe :: Either a b -> b +fromRightUnsafe x = case x of + Left _ -> error "Value is Left" + Right b -> b + +fromLeftUnsafe :: Either a b -> a +fromLeftUnsafe x = case x of + Left a -> a + Right _ -> error "Value is Right" \ No newline at end of file diff --git a/src/TestFiles/typeTest.hs b/src/TestFiles/typeTest.hs index 7e6af25..5888a6c 100644 --- a/src/TestFiles/typeTest.hs +++ b/src/TestFiles/typeTest.hs @@ -2,12 +2,10 @@ data Period = MakePeriod { {-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.-} periodMultiplier :: int - {-A time period, e.g. a day, week, month or year of the stream. If the periodMultiplier values is 0 (zero) then period must contain the value D (day).-} - period :: periodEnum {-Test many-} - testMany :: [testType] + testMany :: [TestType] {-Test some-} - testSome :: [testSomeType] + testSome :: [TestSomeType] {-Test zero or one-} - testMaybeOne :: Maybe testZeroOneType + testMaybeOne :: Maybe TestZeroOneType }