refactored type to add supertype

changed typechecker to have multiple errors and lower types can be used as super types

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
+  --Or Bad
---  "1 or False",
+  "1 or False",
   --And Good
   "False and False",
---  --And Bad
+  --And Bad
---  "1 and 2",
+  "1 and 2",
   --Exists Good
   "a exists",
   --Plus Good
   "1.2 + 2.3",
---  --Plus Bad
+  "1 + 2.3",
---  "True + 2",
+  "1 + 2",
+  --Plus Bad
+  "True + 2",
   --If Good
   "if True then 2 else 3",
---  --If Bad Cond
+  --If Bad Cond
---  "if 2 then True else False",
+  "if 2 then True else False",
   --If Bad exps
---  "if True then 2 else False"
+  "if True then 2 else False",
-    "if True or False then 24 + 15 else 55 + 98 + 35 + 34"
+  "if True or False then 24 + 15 else 55 + 98 + 35 + 34"
   ]

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

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
+        dName <- optional enumValueDisplayNameParser
-        vDescription <- descriptionParser
+        vDescription <- optional descriptionParser
-        return (MakeEnumValue vName (Just vDescription) (Just dName))
+        return (MakeEnumValue vName vDescription dName)
 
 enumValueDisplayNameParser :: Parser String
 enumValueDisplayNameParser =

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
         

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
+        pascalNameParser
-        _ <- lexeme $ char ':'
+        
-        return name 
-
 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")
     ]

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 ExactlyOne _) = pretty (typeName typ)
-printCardinality (MakeTypeAttribute _ typ OneOrMore _) = "[" <> pretty typ <> "]"
+printCardinality (MakeTypeAttribute _ typ OneOrMore _) = "[" <> pretty (typeName typ) <> "]"
-printCardinality (MakeTypeAttribute _ typ ZeroOrMore _) = "[" <> pretty typ <> "]"
+printCardinality (MakeTypeAttribute _ typ ZeroOrMore _) = "[" <> pretty (typeName typ) <> "]"
-printCardinality (MakeTypeAttribute _ typ ZeroOrOne _) = "Maybe" <+> pretty typ
+printCardinality (MakeTypeAttribute _ typ ZeroOrOne _) = "Maybe" <+> pretty (typeName typ)

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],
+  argsType :: [Type],
-  returnType :: String
+  returnType :: Type
   }
 
 defaultMap :: [Symbol]
 defaultMap = [
-  Func "or" ["Boolean", "Boolean"] "Boolean",
+  Func "or" [BasicType "Boolean", BasicType "Boolean"] (BasicType "Boolean"),
-  Func "and" ["Boolean", "Boolean"] "Boolean",
+  Func "and" [BasicType "Boolean", BasicType "Boolean"] (BasicType "Boolean"),
-  Func "exists" ["Any"] "Boolean",
+  Func "exists" [BasicType "Any"] (BasicType "Boolean"),
-  Func "is absent" ["Any"] "Boolean",
+  Func "is absent" [BasicType "Any"] (BasicType "Boolean"),
-  Func "single exists" ["Any"] "Boolean",
+  Func "single exists" [BasicType "Any"] (BasicType "Boolean"),
-  Func "multiple exists" ["Any"] "Boolean",
+  Func "multiple exists" [BasicType "Any"] (BasicType "Boolean"),
-  Func "contains" ["Any", "Any"] "Boolean",
+  Func "contains" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "disjoint" ["Any", "Any"] "Boolean",
+  Func "disjoint" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
   
-  Func "=" ["Any", "Any"] "Boolean",
+  Func "=" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func ">=" ["Any", "Any"] "Boolean",
+  Func ">=" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "<=" ["Any", "Any"] "Boolean",
+  Func "<=" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "<>" ["Any", "Any"] "Boolean",
+  Func "<>" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func ">" ["Any", "Any"] "Boolean",
+  Func ">" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "<" ["Any", "Any"] "Boolean",
+  Func "<" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "all =" ["Any", "Any"] "Boolean",
+  Func "all =" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "all <>" ["Any", "Any"] "Boolean",
+  Func "all <>" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "any =" ["Any", "Any"] "Boolean",
+  Func "any =" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
-  Func "any <>" ["Any", "Any"] "Boolean",
+  Func "any <>" [BasicType "Any", BasicType "Any"] (BasicType "Boolean"),
   
-  Func "+" ["Integer", "Integer"] "Integer",
+  Func "+" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
-  Func "+" ["Double", "Double"] "Double",
+  Func "+" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
-  Func "-" ["Integer", "Integer"] "Integer",
+  Func "-" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
-  Func "-" ["Double", "Double"] "Double",
+  Func "-" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
-  Func "*" ["Integer", "Integer"] "Integer",
+  Func "*" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
-  Func "*" ["Double", "Double"] "Double",
+  Func "*" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
-  Func "/" ["Integer", "Integer"] "Integer",
+  Func "/" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
-  Func "/" ["Double", "Double"] "Double",
+  Func "/" [BasicType "Double", BasicType "Double"] (BasicType "Double"),
-  Func "^" ["Integer", "Integer"] "Integer",
+  Func "^" [BasicType "Integer", BasicType "Integer"] (BasicType "Integer"),
-  Func "^" ["Double", "Double"] "Double",
+  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 :: [Type] -> Type -> Either Type TypeCheckError
-checkType _ "int" = "Integer"
+checkType _ (MakeType "int" _ _ _) = Left $ BasicType "Integer"
-checkType _ "string" = "String"
+checkType _ (MakeType "string" _ _ _) = Left $ BasicType "String"
-checkType _ "boolean" = "Bool"
+checkType _ (MakeType "number" _ _ _) = Left $ BasicType "Double"
-checkType _ "time" = "Time"
+checkType _ (MakeType "boolean" _ _ _) = Left $ BasicType "Bool"
-checkType _ "number" = "Double"
+checkType _ (MakeType "time" _ _ _) = Left $ BasicType "Time"
 checkType definedTypes name
-    | name `elem` definedTypes = name
+    | name `elem` definedTypes = Left name
-    | otherwise = error "Undefined type: " ++ 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 :: [Symbol] -> Expression -> Either Type TypeCheckError
-checkExpression symbolMap (Variable var) = findVar var symbolMap
+checkExpression symbolMap (Variable var) = findVarType var symbolMap
-checkExpression _ (Int _) = "Integer"
+checkExpression _ (Int _) = Left $ BasicType "Integer"
-checkExpression _ (Real _) = "Double"
+checkExpression _ (Real _) = Left $ BasicType "Double"
-checkExpression _ (Boolean _) = "Boolean"
+checkExpression _ (Boolean _) = Left $ BasicType "Boolean"
-checkExpression _ Empty = "Empty"
+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
+    | isLeft condType && isLeft (typeMatch (fromLeftUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex
-    | otherwise = error "Expected boolean condition in if statement"
+    | otherwise = Right IfConditionNotBoolean
     where condType = checkExpression symbolMap cond
 checkExpression symbolMap (IfElse cond ex1 ex2)
-    | condType /= "Boolean" = error "Expected boolean condition in if statement" 
+    | isRight condType || isRight (typeMatch (fromLeftUnsafe condType) (BasicType "Boolean")) = Right IfConditionNotBoolean 
-    | not (typeMatch ex1Type ex2Type) = error "Types of then and else branches don't match"
+    | 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 :: [Symbol] -> String -> [Either Type TypeCheckError] -> Either Type TypeCheckError
-checkFunctionCall [] fun args = error "Undefined function: " ++ fun ++ concat args
+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
+--Try to match 2nd type to first type
-typeMatch "Any" _ = True
+typeMatch :: Type -> Type -> Either Type TypeCheckError
-typeMatch _ "Any" = True
+typeMatch (BasicType "Any") x = Left x
-typeMatch s s2 = s == s2
+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
+findVarType :: String -> [Symbol] -> Either Type TypeCheckError
-findVar var [] = error "Undefined variable " ++ var
+findVarType var [] = Right $ UndefinedVariable var
-findVar x ((Var name typ):symbols) 
+findVarType x ((Var name typ):symbols) 
-    | x == name = typ
+    | x == name = Left typ
-    | otherwise = findVar x symbols
+    | otherwise = findVarType x symbols
-findVar x (_:symbols) = findVar 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"

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
 }