From 3890ed5f0309b0cad04584f5847ff35214d40a9d Mon Sep 17 00:00:00 2001 From: macocianradu Date: Thu, 11 Nov 2021 17:25:30 +0100 Subject: [PATCH] Parser and type checker almost completely working Added testing env --- RosettaParser.cabal | 22 +-- RosettaParser.iml | 20 +++ app/Main.hs | 58 +------ package.yaml | 15 +- resources/Enums/testEnum1.rosetta | 4 + resources/Enums/testEnum2.rosetta | 4 + resources/Enums/testEnum3.rosetta | 3 + resources/Enums/testEnum4.rosetta | 3 + resources/Enums/testEnum5.rosetta | 3 + resources/Enums/testEnum6.rosetta | 3 + resources/Types/testType1.rosetta | 6 + resources/Types/testType2.rosetta | 2 + resources/Types/testType3.rosetta | 2 + resources/Types/testType4.rosetta | 2 + resources/Types/testType5.rosetta | 2 + resources/Types/testType6.rosetta | 2 + resources/Types/testType7.rosetta | 2 + .../testFunction.rosetta | 0 src/Model/Enum.hs | 4 +- src/Model/Function.hs | 22 +-- src/Model/Type.hs | 10 +- src/Parser/Enum.hs | 28 +--- src/Parser/Expression.hs | 20 +-- src/Parser/Type.hs | 62 +++----- src/PrettyPrinter/Type.hs | 18 ++- src/Semantic/ExpressionChecker.hs | 131 ++++++++++++++++ src/Semantic/TypeChecker.hs | 146 ++---------------- src/TestFiles/functionTest.hs | 7 - src/TestFiles/testEnum.rosetta | 4 - src/TestFiles/testType.rosetta | 14 -- src/TestFiles/typeEnum.hs | 13 -- src/TestFiles/typeTest.hs | 11 -- 32 files changed, 287 insertions(+), 356 deletions(-) create mode 100755 resources/Enums/testEnum1.rosetta create mode 100755 resources/Enums/testEnum2.rosetta create mode 100755 resources/Enums/testEnum3.rosetta create mode 100755 resources/Enums/testEnum4.rosetta create mode 100755 resources/Enums/testEnum5.rosetta create mode 100755 resources/Enums/testEnum6.rosetta create mode 100644 resources/Types/testType1.rosetta create mode 100644 resources/Types/testType2.rosetta create mode 100644 resources/Types/testType3.rosetta create mode 100644 resources/Types/testType4.rosetta create mode 100644 resources/Types/testType5.rosetta create mode 100644 resources/Types/testType6.rosetta create mode 100644 resources/Types/testType7.rosetta rename {src/TestFiles => resources}/testFunction.rosetta (100%) create mode 100644 src/Semantic/ExpressionChecker.hs delete mode 100644 src/TestFiles/functionTest.hs delete mode 100755 src/TestFiles/testEnum.rosetta delete mode 100644 src/TestFiles/testType.rosetta delete mode 100644 src/TestFiles/typeEnum.hs delete mode 100644 src/TestFiles/typeTest.hs diff --git a/RosettaParser.cabal b/RosettaParser.cabal index 1988952..b2b1726 100644 --- a/RosettaParser.cabal +++ b/RosettaParser.cabal @@ -6,12 +6,12 @@ cabal-version: 1.12 name: RosettaParser version: 0.1.0.0 -description: Please see the README on GitHub at -homepage: https://github.com/githubuser/RosettaParser#readme -bug-reports: https://github.com/githubuser/RosettaParser/issues -author: Author name here -maintainer: example@example.com -copyright: 2021 Author name here +description: Please see the README on GitHub at +homepage: https://github.com/macocianradu/RosettaParser#readme +bug-reports: https://github.com/macocianradu/RosettaParser/issues +author: Adrian Radu Macocian +maintainer: rmacocian@gmail.com +copyright: 2021 Adrian Radu Macocian license: BSD3 license-file: LICENSE build-type: Simple @@ -21,7 +21,7 @@ extra-source-files: source-repository head type: git - location: https://github.com/githubuser/RosettaParser + location: https://github.com/macocianradu/RosettaParser library exposed-modules: @@ -37,6 +37,7 @@ library PrettyPrinter.Function PrettyPrinter.General PrettyPrinter.Type + Semantic.ExpressionChecker Semantic.TypeChecker other-modules: Paths_RosettaParser @@ -54,8 +55,6 @@ library executable RosettaParser-exe main-is: Main.hs - other-modules: - Paths_RosettaParser hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N @@ -74,6 +73,9 @@ test-suite RosettaParser-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Parser.EnumSpec + Parser.ExpressionSpec + Parser.TypeSpec Paths_RosettaParser hs-source-dirs: test @@ -81,6 +83,8 @@ test-suite RosettaParser-test build-depends: RosettaParser , base >=4.7 && <5 + , hspec + , hspec-megaparsec , megaparsec , mtl , parser-combinators diff --git a/RosettaParser.iml b/RosettaParser.iml index 48a75b6..445391a 100644 --- a/RosettaParser.iml +++ b/RosettaParser.iml @@ -33,5 +33,25 @@ + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/app/Main.hs b/app/Main.hs index 313599b..79264bb 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,10 +8,9 @@ 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) +import Model.Type main :: IO () main = do @@ -25,24 +24,24 @@ main = do testEnum :: IO() testEnum = do - rosettaString <- readFile "src/TestFiles/testEnum.rosetta" + rosettaString <- readFile "resources/Enums/testEnum5.rosetta" case parse enumParser "" (Text.pack rosettaString) of - Left errorBundle -> print (errorBundlePretty errorBundle) + Left errorBundle -> print errorBundle Right enum -> do putStrLn $ printEnum enum - writeFile "src/TestFiles/typeEnum.hs" (printEnum enum) + writeFile "resources/Generated/generatedEnum.hs" (printEnum enum) testTypeParser :: IO() testTypeParser = do - rosettaString <- readFile "src/TestFiles/testType.rosetta" + rosettaString <- readFile "resources/Types/testType1.rosetta" case parse typeParser "" (Text.pack rosettaString) of Left errorBundle -> print (errorBundlePretty errorBundle) Right typ -> do putStrLn $ printType typ print typ - writeFile "src/TestFiles/typeTest.hs" (printType typ) + writeFile "resources/Generated/generatedType.hs" (printType typ) testTypeChecker :: IO () testTypeChecker = do @@ -56,52 +55,11 @@ testTypeChecker = do testFunc :: IO() testFunc = do - rosettaString <- readFile "src/TestFiles/testFunction.rosetta" + rosettaString <- readFile "resources/testFunction.rosetta" 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 = 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, 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", - --And Good - "False and False", - --And Bad - "1 and 2", - --Exists Good - "a exists", - --Plus Good - "1.2 + 2.3", - "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 exps - "if True then 2 else False", - "if True or False then 24 + 15 else 55 + 98 + 35 + 34" - ] \ No newline at end of file + writeFile "resources/Generated/generatedFunction.hs" (show $ printFunctionSignature fun) \ No newline at end of file diff --git a/package.yaml b/package.yaml index 7f93a1b..cc33771 100644 --- a/package.yaml +++ b/package.yaml @@ -1,10 +1,10 @@ name: RosettaParser version: 0.1.0.0 -github: "githubuser/RosettaParser" +github: "macocianradu/RosettaParser" license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2021 Author name here" +author: "Adrian Radu Macocian" +maintainer: "rmacocian@gmail.com" +copyright: "2021 Adrian Radu Macocian" extra-source-files: - README.md @@ -17,7 +17,7 @@ extra-source-files: # To avoid duplicated efforts in documentation and dealing with the # complications of embedding Haddock markup inside cabal files, it is # common to point users to the README.md file. -description: Please see the README on GitHub at +description: Please see the README on GitHub at dependencies: - base >= 4.7 && < 5 @@ -41,6 +41,9 @@ executables: - -with-rtsopts=-N dependencies: - RosettaParser + when: + - condition: false + other-modules: Paths_RosettaParser tests: RosettaParser-test: @@ -52,3 +55,5 @@ tests: - -with-rtsopts=-N dependencies: - RosettaParser + - hspec-megaparsec + - hspec \ No newline at end of file diff --git a/resources/Enums/testEnum1.rosetta b/resources/Enums/testEnum1.rosetta new file mode 100755 index 0000000..00df574 --- /dev/null +++ b/resources/Enums/testEnum1.rosetta @@ -0,0 +1,4 @@ +enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week."> + D displayName "day" <"Day"> + M displayName "month" <"Month"> + Y displayName "year" <"Year"> diff --git a/resources/Enums/testEnum2.rosetta b/resources/Enums/testEnum2.rosetta new file mode 100755 index 0000000..2682eb9 --- /dev/null +++ b/resources/Enums/testEnum2.rosetta @@ -0,0 +1,4 @@ +enum EnumWithoutDisplay: <"The enumerated values to specified the period, e.g. day, week."> + D <"Day"> + M <"Month"> + Y <"Year"> diff --git a/resources/Enums/testEnum3.rosetta b/resources/Enums/testEnum3.rosetta new file mode 100755 index 0000000..348a354 --- /dev/null +++ b/resources/Enums/testEnum3.rosetta @@ -0,0 +1,3 @@ +enum EnumWithoutDescription: + X displayName "xs" + Y displayName "ys" \ No newline at end of file diff --git a/resources/Enums/testEnum4.rosetta b/resources/Enums/testEnum4.rosetta new file mode 100755 index 0000000..a2ee785 --- /dev/null +++ b/resources/Enums/testEnum4.rosetta @@ -0,0 +1,3 @@ +enum Wrong: + A <"asd"> displayName "dsa" + B <"xyz"> displayName "zyx" diff --git a/resources/Enums/testEnum5.rosetta b/resources/Enums/testEnum5.rosetta new file mode 100755 index 0000000..5a2d44a --- /dev/null +++ b/resources/Enums/testEnum5.rosetta @@ -0,0 +1,3 @@ +enum Wrong2 + A <"asd"> displayName "dsa" + B <"xyz"> displayName "zyx" diff --git a/resources/Enums/testEnum6.rosetta b/resources/Enums/testEnum6.rosetta new file mode 100755 index 0000000..9a42287 --- /dev/null +++ b/resources/Enums/testEnum6.rosetta @@ -0,0 +1,3 @@ +enum Wrong3:: + A <"asd"> displayName "dsa" + B <"xyz"> displayName "zyx" diff --git a/resources/Types/testType1.rosetta b/resources/Types/testType1.rosetta new file mode 100644 index 0000000..7af2ef0 --- /dev/null +++ b/resources/Types/testType1.rosetta @@ -0,0 +1,6 @@ +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."> + testMany TestType (0..*) <"Test many"> + testSome TestSomeType (1..*) <"Test some"> + testMaybeOne TestZeroOneType (0..1) <"Test zero or one"> + testAll Test (2..15) <"Test all"> \ No newline at end of file diff --git a/resources/Types/testType2.rosetta b/resources/Types/testType2.rosetta new file mode 100644 index 0000000..1be9651 --- /dev/null +++ b/resources/Types/testType2.rosetta @@ -0,0 +1,2 @@ +type TestType: + periodMultiplier int (1..1) \ No newline at end of file diff --git a/resources/Types/testType3.rosetta b/resources/Types/testType3.rosetta new file mode 100644 index 0000000..f2975ae --- /dev/null +++ b/resources/Types/testType3.rosetta @@ -0,0 +1,2 @@ +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."> \ No newline at end of file diff --git a/resources/Types/testType4.rosetta b/resources/Types/testType4.rosetta new file mode 100644 index 0000000..692d7fe --- /dev/null +++ b/resources/Types/testType4.rosetta @@ -0,0 +1,2 @@ +type TestZeroOneType extends Period: + periodMultiplier int (1..1) \ No newline at end of file diff --git a/resources/Types/testType5.rosetta b/resources/Types/testType5.rosetta new file mode 100644 index 0000000..28d7cad --- /dev/null +++ b/resources/Types/testType5.rosetta @@ -0,0 +1,2 @@ +type WrongCardinality: <"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."> \ No newline at end of file diff --git a/resources/Types/testType6.rosetta b/resources/Types/testType6.rosetta new file mode 100644 index 0000000..2675822 --- /dev/null +++ b/resources/Types/testType6.rosetta @@ -0,0 +1,2 @@ +type WrongCardinality2: <"description"> + periodMultiplier int (1..a) <"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."> \ No newline at end of file diff --git a/resources/Types/testType7.rosetta b/resources/Types/testType7.rosetta new file mode 100644 index 0000000..677e2fa --- /dev/null +++ b/resources/Types/testType7.rosetta @@ -0,0 +1,2 @@ +type MissingType: <"description"> + periodMultiplier (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."> \ No newline at end of file diff --git a/src/TestFiles/testFunction.rosetta b/resources/testFunction.rosetta similarity index 100% rename from src/TestFiles/testFunction.rosetta rename to resources/testFunction.rosetta diff --git a/src/Model/Enum.hs b/src/Model/Enum.hs index 8171d83..beb3463 100644 --- a/src/Model/Enum.hs +++ b/src/Model/Enum.hs @@ -4,10 +4,10 @@ data EnumType = MakeEnum { enumName :: String, enumDescription :: Maybe String, enumValues :: [EnumValue] -} deriving (Show) +} deriving (Show, Eq) data EnumValue = MakeEnumValue { enumValueName :: String, enumValueDescription :: Maybe String, enumValueDisplayName :: Maybe String -} deriving (Show) \ No newline at end of file +} deriving (Show, Eq) \ No newline at end of file diff --git a/src/Model/Function.hs b/src/Model/Function.hs index 89d9209..501e17d 100644 --- a/src/Model/Function.hs +++ b/src/Model/Function.hs @@ -12,16 +12,16 @@ data Function = } deriving (Show) -data Condition = - MakeCondition { - conditionDescription :: Maybe String, - conditionStatement :: Expression - } - | MakePostCondition { - conditionDescription :: Maybe String, - conditionStatement :: Expression - } - deriving (Show) +--data Condition = +-- MakeCondition { +-- conditionDescription :: Maybe String, +-- conditionStatement :: Expression +-- } +-- | MakePostCondition { +-- conditionDescription :: Maybe String, +-- conditionStatement :: Expression +-- } +-- deriving (Show) data Expression = Variable String | Int String @@ -36,4 +36,4 @@ data Expression = Variable String | InfixExp String Expression Expression | IfSimple Expression Expression | IfElse Expression Expression Expression - deriving (Show) \ No newline at end of file + deriving (Eq, Show) \ No newline at end of file diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 096b5ed..5bb5988 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -30,9 +30,7 @@ data TypeAttribute = MakeTypeAttribute { } deriving (Show) --TODO use bounded class -data Cardinality = - ZeroOrOne - | ExactlyOne - | OneOrMore -- One or more - | ZeroOrMore -- Zero or more - deriving (Show) \ No newline at end of file +data Cardinality = Bounds (Integer, Integer) + | OneBound Integer + | NoBounds + deriving Show \ No newline at end of file diff --git a/src/Parser/Enum.hs b/src/Parser/Enum.hs index e1256c3..aea15ba 100755 --- a/src/Parser/Enum.hs +++ b/src/Parser/Enum.hs @@ -7,16 +7,14 @@ import Text.Megaparsec.Char import Text.Megaparsec import Model.Enum ---parseTest enumParser "enum periodEnum: <\"description\"> D displayName \"day\" <\"Day\">" enumParser :: Parser EnumType enumParser = do eName <- enumNameParser eDescription <- optional descriptionParser - values <- many enumValueParser + values <- some enumValueParser return (MakeEnum eName eDescription values) - ---parseTest enumValueParser "D displayName \"day\" <\"Day\">" + enumValueParser :: Parser EnumValue enumValueParser = do @@ -38,24 +36,4 @@ enumNameParser = _ <- lexeme $ string "enum" name <- nameParser _ <- lexeme $ char ':' - return name - -periodEnum :: EnumType -periodEnum = MakeEnum - "PeriodEnum" - (Just "The enumerated values to specifie the period, e.g. day, week.") - [MakeEnumValue - "D" - (Just "Day") - Nothing, - - MakeEnumValue - "W" - (Just "Week") - Nothing, - - MakeEnumValue - "Y" - (Just "Year") - Nothing - ] \ No newline at end of file + return name \ No newline at end of file diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 0b73395..a54a002 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -75,7 +75,7 @@ integerParser :: Parser Expression integerParser = do nr <- lexeme $ some digitChar - return $ Int $ show nr + return $ Int nr decimalParser :: Parser Expression decimalParser = @@ -83,7 +83,7 @@ decimalParser = nr <- some digitChar _ <- char '.' real <- lexeme $ many digitChar - return $ Real $ show nr ++ "." ++ real + return $ Real $ nr ++ "." ++ real booleanParser :: Parser Expression booleanParser = @@ -202,18 +202,4 @@ precedence "^" = 4 precedence _ = 100 prefixOperators :: [String] -prefixOperators = ["-", "not"] - -testArith3 = parseTest expressionParser "1 + (2 - 3)" -testArith4 = parseTest expressionParser "a * b - c * d - e * f = g * h - i * j - k * l" -testArith5 = parseTest expressionParser "a + b - c * d ^ e" -testArith6 = parseTest expressionParser "1 - 2 - 3 - 4 - 5 - 6" -testList = parseTest expressionParser "[1, 2, 3]" -testList2 = parseTest expressionParser "[1, 2 + 3, e]" -testFun = parseTest functionCallParser "Function()" -testFun2 = parseTest functionCallParser "Function(e)" -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" \ No newline at end of file +prefixOperators = ["-", "not"] \ No newline at end of file diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index fad0b6d..a17b387 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -7,7 +7,6 @@ import Text.Megaparsec.Char import Text.Megaparsec import Parser.General ---parseTest typeParser "type Period: <\"description\"> periodMultiplier int (1..1) <\"A time period multiplier\"> period periodEnum (1..1) <\"A time period \">" typeParser :: Parser Type typeParser = do @@ -21,7 +20,7 @@ typeParser = superTypeParser :: Parser Type superTypeParser = do - _ <- lexeme $ string "extending" + _ <- lexeme $ string "extends" name <- pascalNameParser return $ MakeType name Nothing Nothing [] @@ -37,55 +36,36 @@ typeAttributeParser = cardinalityParser :: Parser Cardinality cardinalityParser = do - parseExactlyOne <|> parseOneOrMore <|> parseZeroOrMore <|> parseZeroOrOne + try parseBounded <|> try parseSemiBounded <|> try parseUnbounded -parseOneOrMore :: Parser Cardinality -parseOneOrMore = +parseBounded :: Parser Cardinality +parseBounded = do - _ <- lexeme $ string "(1..*)" - return OneOrMore + _ <- lexeme $ char '(' + low <- lexeme $ many digitChar + _ <- lexeme $ string ".." + up <- lexeme $ many digitChar + _ <- lexeme $ char ')' + return $ Bounds (read low, read up) -parseExactlyOne :: Parser Cardinality -parseExactlyOne = +parseSemiBounded :: Parser Cardinality +parseSemiBounded = do - _ <- lexeme $ string "(1..1)" - return ExactlyOne + _ <- lexeme $ char '(' + low <- lexeme $ many digitChar + _ <- lexeme $ string "..*)" + return $ OneBound $ read low -parseZeroOrMore :: Parser Cardinality -parseZeroOrMore = +parseUnbounded :: Parser Cardinality +parseUnbounded = do - _ <- lexeme $ string "(0..*)" - return ZeroOrMore - - -parseZeroOrOne :: Parser Cardinality -parseZeroOrOne = - do - _ <- lexeme $ string "(0..1)" - return ZeroOrOne + _ <- lexeme $ string "(*..*)" + return NoBounds typeNameParser :: Parser String typeNameParser = do _ <- lexeme $ string "type" - pascalNameParser - -periodType :: Type -periodType = MakeType - "Period" - Nothing - (Just "A class to define recurring periods or time offsets") - [MakeTypeAttribute - "periodMultiplier" - (BasicType "Integer") - ExactlyOne - (Just "A time period multiplier"), - - MakeTypeAttribute - "period" - (MakeType "PeriodEnum" Nothing Nothing []) - ExactlyOne - (Just "A time period") - ] \ No newline at end of file + pascalNameParser \ No newline at end of file diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index b9d5fe8..f108e56 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -8,16 +8,24 @@ import Model.Type printType :: Type -> String printType (MakeType name _ description attributes) = - show $ printDescription description (vcat [nest 4 $ vcat("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": map printAttribute attributes), "}", ""]) + show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": map printAttribute attributes), "}", ""]) printType (BasicType name) = show $ pretty name +printAttributes :: [TypeAttribute] -> [Doc a] +printAttributes [] = [] +printAttributes [at] = [printAttribute at] +printAttributes (at : ats) = (printAttribute at <> ",") : printAttributes ats + + 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 (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 +printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _) + | x == 0 && y == 1 = "Maybe" <+> pretty (typeName typ) + | x == 1 && y == 1 = pretty (typeName typ) + | otherwise = "[" <> pretty (typeName typ) <> "]" +printCardinality (MakeTypeAttribute _ typ NoBounds _) = "[" <> pretty (typeName typ) <> "]" +printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]" \ No newline at end of file diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs new file mode 100644 index 0000000..83e147a --- /dev/null +++ b/src/Semantic/ExpressionChecker.hs @@ -0,0 +1,131 @@ +module Semantic.ExpressionChecker where + +import Model.Function +import Data.Either +import Data.Maybe +import Model.Type +import Semantic.TypeChecker + +data Symbol = Var{ + varName :: String, + declaredType :: Type + } + | Func { + funcName :: String, + argsType :: [Type], + returnType :: Type + } + +defaultMap :: [Symbol] +defaultMap = [ + 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 "=" [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 "+" [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" [BasicType "Any"] (BasicType "Integer") + ] + +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 symbolMap (List lst) = checkList symbolMap lst +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) + | 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) + | 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 + +checkList :: [Symbol] -> [Expression] -> Either Type TypeCheckError +checkList symbs exps + | isLeft typ && fromLeftUnsafe typ == BasicType "Any" = Left $ BasicType "Empty" + | otherwise = typ + where typ = checkList1 symbs exps (BasicType "Any") + +checkList1 :: [Symbol] -> [Expression] -> Type -> Either Type TypeCheckError +checkList1 _ [] typ = Left typ +checkList1 symbs (ex : exps) typ + | isRight exTyp = exTyp + | isRight match = match + | otherwise = checkList1 symbs exps (fromLeftUnsafe match) + where + exTyp = checkExpression symbs ex + match = typeMatch typ (fromLeftUnsafe exTyp) + +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 + | 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 + +--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) + +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/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index 842a77a..402943d 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -1,65 +1,16 @@ 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 :: Type - } - | Func { - funcName :: String, - argsType :: [Type], - returnType :: Type - } - -defaultMap :: [Symbol] -defaultMap = [ - 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 "=" [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 "+" [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" [BasicType "Any"] (BasicType "Integer") - ] + UndefinedType String + | IfConditionNotBoolean + | IfExpressionsDifferentTypes + | UndefinedFunction String + | ErrorInsideFunction + | UndefinedVariable String + | TypeMismatch String String + deriving (Show) checkAttributes :: [Type] -> [TypeAttribute] -> [Either Type TypeCheckError] checkAttributes _ [] = [] @@ -74,85 +25,8 @@ checkType _ (MakeType "time" _ _ _) = Left $ BasicType "Time" checkType definedTypes name | name `elem` definedTypes = Left name | otherwise = Right $ UndefinedType (typeName name) - + addDefinedTypes :: [Type] -> [Type] -> [Type] addDefinedTypes l [] = l addDefinedTypes l (BasicType _ : ts) = addDefinedTypes l ts -addDefinedTypes l (t:ts) = t : 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 -> 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 ---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) - | 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) - | 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 -> [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 - | 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 - ---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) - -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 +addDefinedTypes l (t:ts) = t : addDefinedTypes l ts \ No newline at end of file diff --git a/src/TestFiles/functionTest.hs b/src/TestFiles/functionTest.hs deleted file mode 100644 index 8efae20..0000000 --- a/src/TestFiles/functionTest.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class.-} -EquityPriceObservation :: Equity - -> AdjustableOrRelativeDate - -> Maybe BusinessCenterTime - -> Maybe TimeTypeEnum - -> [DeterminationMethodEnum] - -> ObservationPrimitive \ No newline at end of file diff --git a/src/TestFiles/testEnum.rosetta b/src/TestFiles/testEnum.rosetta deleted file mode 100755 index b00a9d1..0000000 --- a/src/TestFiles/testEnum.rosetta +++ /dev/null @@ -1,4 +0,0 @@ -enum PeriodEnum: <"description"> - D displayName "day" <"Day"> - M displayName "month" <"Month"> - Y displayName "year" <"Year"> \ No newline at end of file diff --git a/src/TestFiles/testType.rosetta b/src/TestFiles/testType.rosetta deleted file mode 100644 index a6c36e6..0000000 --- a/src/TestFiles/testType.rosetta +++ /dev/null @@ -1,14 +0,0 @@ -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."> - testMany TestType (0..*) <"Test many"> - testSome TestSomeType (1..*) <"Test some"> - testMaybeOne TestZeroOneType (0..1) <"Test zero or one"> - -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."> \ No newline at end of file diff --git a/src/TestFiles/typeEnum.hs b/src/TestFiles/typeEnum.hs deleted file mode 100644 index 63d55da..0000000 --- a/src/TestFiles/typeEnum.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-description-} -data PeriodEnum = - {-Day-} - D - {-Month-} - | M - {-Year-} - | Y - -instance Show PeriodEnum where - show D = "day" - show M = "month" - show Y = "year" \ No newline at end of file diff --git a/src/TestFiles/typeTest.hs b/src/TestFiles/typeTest.hs deleted file mode 100644 index 5888a6c..0000000 --- a/src/TestFiles/typeTest.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-description-} -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 - {-Test many-} - testMany :: [TestType] - {-Test some-} - testSome :: [TestSomeType] - {-Test zero or one-} - testMaybeOne :: Maybe TestZeroOneType -}