refactored type to add supertype

changed typechecker to have multiple errors and lower types can be used as super types
2026-03-18 21:10:07 +00:00 · 2021-10-31 21:36:55 +01:00
parent 9437c6bd7a
commit 464ef29caa
8 changed files with 167 additions and 111 deletions
--- 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"
  ]
--- 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
--- 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 =
--- 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
        
--- 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")
    ]
--- 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
+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)
--- 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
+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"
--- 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
 }