added type checker

RosettaParser.cabal

@@ -37,6 +37,7 @@ library
       PrettyPrinter.Function
       PrettyPrinter.General
       PrettyPrinter.Type
+      Semantic.TypeChecker
   other-modules:
       Paths_RosettaParser
   hs-source-dirs:
@@ -44,6 +45,7 @@ library
   build-depends:
       base >=4.7 && <5
     , megaparsec
+    , mtl
     , parser-combinators
     , prettyprinter
     , text
@@ -61,6 +63,7 @@ executable RosettaParser-exe
       RosettaParser
     , base >=4.7 && <5
     , megaparsec
+    , mtl
     , parser-combinators
     , prettyprinter
     , text
@@ -79,6 +82,7 @@ test-suite RosettaParser-test
       RosettaParser
     , base >=4.7 && <5
     , megaparsec
+    , mtl
     , parser-combinators
     , prettyprinter
     , text

app/Main.hs

@@ -3,13 +3,15 @@ module Main where
 import Parser.Enum
 import Parser.Type
 import Parser.Function
-import Data.Text
+import qualified Data.Text as Text
 import Text.Megaparsec
 import PrettyPrinter.Enum
 import PrettyPrinter.Type
 import PrettyPrinter.Function
 import Parser.Expression
+import Semantic.TypeChecker
 import Model.Function
+import Model.Type (typeAttributes)
 
 main :: IO ()
 main = do
@@ -17,24 +19,24 @@ main = do
     putStrLn "rosetta String: " 
     putStrLn rosettaString
     putStrLn "\nFinal enum: \n"
-    case parse enumParser "" (pack rosettaString) of
+    case parse enumParser "" (Text.pack rosettaString) of
         Left errorBundle -> print (errorBundlePretty errorBundle)
         Right enum -> putStrLn $ printEnum enum
 
 testEnum :: IO()
 testEnum = do
     rosettaString <- readFile "src/TestFiles/testEnum.rosetta"
-    case parse enumParser "" (pack rosettaString) of
+    case parse enumParser "" (Text.pack rosettaString) of
         Left errorBundle -> print (errorBundlePretty errorBundle)
         Right enum -> 
             do
                 putStrLn $ printEnum enum
                 writeFile "src/TestFiles/typeEnum.hs" (printEnum enum) 
         
-testType :: IO()
+testTypeParser :: IO()
-testType = do
+testTypeParser = do
     rosettaString <- readFile "src/TestFiles/testType.rosetta"
-    case parse typeParser "" (pack rosettaString) of
+    case parse typeParser "" (Text.pack rosettaString) of
         Left errorBundle -> print (errorBundlePretty errorBundle)
         Right typ -> 
             do
@@ -42,13 +44,58 @@ testType = do
                 print typ
                 writeFile "src/TestFiles/typeTest.hs" (printType typ) 
               
+testTypeChecker :: IO ()
+testTypeChecker = do
+    rosettaString <- readFile "src/TestFiles/testType.rosetta"
+    case parse (many typeParser) "" (Text.pack rosettaString) of
+        Left errorBundle -> print (errorBundlePretty errorBundle)
+        Right typ -> 
+            do
+                print $ map (checkAttributes definedTypes . typeAttributes) typ
+                where definedTypes = addDefinedTypes [] typ
+                
 testFunc :: IO()
 testFunc = do
     rosettaString <- readFile "src/TestFiles/testFunction.rosetta"
-    case parse functionParser "" (pack rosettaString) of
+    case parse functionParser "" (Text.pack rosettaString) of
         Left errorBundle -> print (errorBundlePretty errorBundle)
         Right fun -> 
             do
                 print $ printFunctionSignature fun
                 print (assignments fun)
                 writeFile "src/TestFiles/functionTest.hs" (show $ printFunctionSignature fun) 
+           
+testExpTypeChecker :: IO ()
+testExpTypeChecker = print $ 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
+            
+expressions :: [String]
+expressions = [
+  --Or Good
+  "True or False",
+--  --Or Bad
+--  "1 or False",
+  --And Good
+  "False and False",
+--  --And Bad
+--  "1 and 2",
+  --Exists Good
+  "a exists",
+  --Plus Good
+  "1.2 + 2.3",
+--  --Plus Bad
+--  "True + 2",
+  --If Good
+  "if True then 2 else 3",
+--  --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"
+  ]

package.yaml

@@ -23,6 +23,7 @@ dependencies:
 - base >= 4.7 && < 5
 - megaparsec
 - time
+- mtl
 - prettyprinter
 - parser-combinators
 - text

src/Model/Type.hs

@@ -1,19 +1,8 @@
 module Model.Type where
 
 import Data.Time.LocalTime()
-import Model.Enum
 
-data BasicType = String 
+data Type = MakeType {
-    | Integer 
-    | Double 
-    | Boolean 
-    | TimeOfDay
-    deriving (Show)
-
-data Type = 
-    TypeFromBasicType BasicType
-    | TypeFromEnum EnumType
-    | MakeType {
         typeName :: String,
         typeDescription :: Maybe String,
         typeAttributes :: [TypeAttribute]

src/Parser/Expression.hs

@@ -125,11 +125,14 @@ eqParser :: Parser Expression
 eqParser =
     do
         s <- sumParser
-        op <- lexeme $ observing (string  "<=" <|> string "=" <|> string "<" <|> string ">" <|> string ">=")
+        op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) eqFunctions
         case op of
             Left _ -> return s
             Right o -> eqParser >>= \ex -> return $ InfixExp (Text.unpack o) s ex
 
+eqFunctions :: [String]
+eqFunctions = ["=", "<", "<=", ">", ">=", "<>", "all =", "all <>", "any =", "any <>"]
+
 sumParser :: Parser Expression
 sumParser =
     do
@@ -148,10 +151,19 @@ factorParser =
             Left _ -> return p
             Right o -> factorParser >>= \ex -> return $ reverseExpression $ InfixExp [o] p ex
 
+boolOpParser :: Parser Expression
+boolOpParser = 
+    do 
+        p <- postfixParser
+        op <- lexeme $ observing (string "or" <|> string "and")
+        case op of
+            Left _ -> return p
+            Right o -> boolOpParser >>= \ex -> return $ InfixExp (Text.unpack o) p ex
+
 powerParser :: Parser Expression
 powerParser = 
     do
-        p <- postfixParser
+        p <- boolOpParser
         op <- lexeme $ observing $ char '^'
         case op of
             Left _ -> return p
@@ -161,11 +173,14 @@ postfixParser :: Parser Expression
 postfixParser = 
     do
         t <- terminalParser
-        op <- lexeme $ observing (string "exists" <|> string "is absent" <|> string "count" <|> string "only-element")
+        op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) postfixFunctions
         case op of
             Left _ -> return t
             Right o -> return $ PostfixExp (Text.unpack o) t
 
+postfixFunctions :: [String]
+postfixFunctions = ["exists", "is absent", "count", "only-element", "single exists", "multiple exists"]
+
 --------------------------------------------
 -- Auxiliary  ------------------------------
 --------------------------------------------
@@ -201,3 +216,4 @@ testFun3 = parseTest functionCallParser "Function(3, 3+2,e)"
 testIf = parseTest expressionParser "if (Function(2 + 3, e)) then a + b - c * d ^ e -> x else not a exists"
 testEverything = parseTest expressionParser "if [1, Function(3)] then 1 - 2 - 3 * a -> b ^ c"
 testFail = parseTest expressionParser "if[1,as]thenxandoelseaora"
+testOr = parseTest expressionParser "a or b"

src/PrettyPrinter/Type.hs

@@ -5,17 +5,13 @@ module PrettyPrinter.Type where
 import Prettyprinter
 import PrettyPrinter.General
 import Model.Type
-import Model.Enum
 
 printType :: Type -> String
 printType (MakeType name description attributes) =
     show $ printDescription description (vcat [nest 4 $ vcat("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": map printAttribute attributes), "}", ""])
-printType x = show x 
    
 printTypeName :: Type -> String
 printTypeName (MakeType name _ _) = name
-printTypeName (TypeFromBasicType name) = show name
-printTypeName (TypeFromEnum (MakeEnum name _ _)) = name 
 
 printAttribute :: TypeAttribute -> Doc a
 printAttribute (MakeTypeAttribute name typ crd description) =

src/Semantic/TypeChecker.hs

@@ -0,0 +1,126 @@
+module Semantic.TypeChecker where
+
+import Model.Type
+import Model.Function
+
+data Symbol = Var{
+  varName :: String,
+  declaredType :: String
+  }
+  | Func {
+  funcName :: String,
+  argsType :: [String],
+  returnType :: String
+  }
+
+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 "=" ["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 "+" ["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 "count" ["Any"] "Integer"
+  ]
+
+checkAttributes :: [String] -> [TypeAttribute] -> [String]
+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 definedTypes name
+    | name `elem` definedTypes = name
+    | otherwise = error "Undefined type: " ++ name
+  
+addDefinedTypes :: [String] -> [Type] -> [String]
+addDefinedTypes l [] = l
+addDefinedTypes l ((MakeType name _ _):ts) = name : addDefinedTypes l ts
+
+--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
+    
+checkExpression :: [Symbol] -> Expression -> String
+checkExpression symbolMap (Variable var) = findVar var symbolMap
+checkExpression _ (Int _) = "Integer"
+checkExpression _ (Real _) = "Double"
+checkExpression _ (Boolean _) = "Boolean"
+checkExpression _ Empty = "Empty"
+checkExpression symbolMap (Parens ex) = checkExpression symbolMap ex
+checkExpression _ (List _) = "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"
+    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"
+    | 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 ((Func n a r):symbolMap) name args
+    | name == n && and (zipWith typeMatch a args) = r
+    | otherwise = checkFunctionCall symbolMap name args
+checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args 
+
+typeMatch :: String -> String -> Bool
+typeMatch "Any" _ = True
+typeMatch _ "Any" = True
+typeMatch s s2 = s == 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

src/TestFiles/testType.rosetta

@@ -1,13 +1,14 @@
 type Period: <"description">
     periodMultiplier int (1..1) <"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.">
-    period periodEnum (1..1) <"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).">
+    testMany TestType (0..*) <"Test many">
-    testMany testType (0..*) <"Test many">
+    testSome TestSomeType (1..*) <"Test some">
-    testSome testSomeType (1..*) <"Test some">
+    testMaybeOne TestZeroOneType (0..1) <"Test zero or one">
-    testMaybeOne testZeroOneType (0..1) <"Test zero or one">
 
-type Period: <"description">
+type TestTypeasd: <"description">
+    periodMultiplier int (1..1) <"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.">
+
+type TestSomeType: <"description">
+    periodMultiplier int (1..1) <"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.">
+
+type TestZeroOneType: <"description">
     periodMultiplier int (1..1) <"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.">
-    period periodEnum (1..1) <"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).">
-    testMany testType (0..*) <"Test many">
-    testSome testSomeType (1..*) <"Test some">
-    testMaybeOne testZeroOneType (0..1) <"Test zero or one">