Parser and type checker almost completely working

Added testing env
This commit is contained in:
macocianradu
2021-11-11 17:25:30 +01:00
parent 464ef29caa
commit 3890ed5f03
32 changed files with 287 additions and 356 deletions

View File

@@ -6,12 +6,12 @@ cabal-version: 1.12
name: RosettaParser
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/RosettaParser#readme>
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 <https://github.com/macocianradu/RosettaParser#readme>
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

View File

@@ -33,5 +33,25 @@
<orderEntry type="library" name="pretty-1.1.3.6" level="project" />
<orderEntry type="library" name="time-1.9.3" level="project" />
<orderEntry type="library" name="prettyprinter-1.7.0" level="project" />
<orderEntry type="library" name="hspec-2.7.10" level="project" />
<orderEntry type="library" name="QuickCheck-2.14.2" level="project" />
<orderEntry type="library" name="hspec-core-2.7.10" level="project" />
<orderEntry type="library" name="hspec-discover-2.7.10" level="project" />
<orderEntry type="library" name="hspec-expectations-0.8.2" level="project" />
<orderEntry type="library" name="random-1.2.0" level="project" />
<orderEntry type="library" name="splitmix-0.1.0.3" level="project" />
<orderEntry type="library" name="HUnit-1.6.2.0" level="project" />
<orderEntry type="library" name="ansi-terminal-0.11" level="project" />
<orderEntry type="library" name="call-stack-0.3.0" level="project" />
<orderEntry type="library" name="clock-0.8.2" level="project" />
<orderEntry type="library" name="directory-1.3.6.0" level="project" />
<orderEntry type="library" name="filepath-1.4.2.1" level="project" />
<orderEntry type="library" name="quickcheck-io-0.2.0" level="project" />
<orderEntry type="library" name="setenv-0.1.1.3" level="project" />
<orderEntry type="library" name="stm-2.5.0.1" level="project" />
<orderEntry type="library" name="tf-random-0.5" level="project" />
<orderEntry type="library" name="colour-2.3.6" level="project" />
<orderEntry type="library" name="unix-2.7.2.2" level="project" />
<orderEntry type="library" name="hspec-megaparsec-2.2.0" level="project" />
</component>
</module>

View File

@@ -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"
]
writeFile "resources/Generated/generatedFunction.hs" (show $ printFunctionSignature fun)

View File

@@ -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 <https://github.com/githubuser/RosettaParser#readme>
description: Please see the README on GitHub at <https://github.com/macocianradu/RosettaParser#readme>
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

View File

@@ -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">

View File

@@ -0,0 +1,4 @@
enum EnumWithoutDisplay: <"The enumerated values to specified the period, e.g. day, week.">
D <"Day">
M <"Month">
Y <"Year">

View File

@@ -0,0 +1,3 @@
enum EnumWithoutDescription:
X displayName "xs"
Y displayName "ys"

View File

@@ -0,0 +1,3 @@
enum Wrong:
A <"asd"> displayName "dsa"
B <"xyz"> displayName "zyx"

View File

@@ -0,0 +1,3 @@
enum Wrong2
A <"asd"> displayName "dsa"
B <"xyz"> displayName "zyx"

View File

@@ -0,0 +1,3 @@
enum Wrong3::
A <"asd"> displayName "dsa"
B <"xyz"> displayName "zyx"

View File

@@ -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">

View File

@@ -0,0 +1,2 @@
type TestType:
periodMultiplier int (1..1)

View File

@@ -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.">

View File

@@ -0,0 +1,2 @@
type TestZeroOneType extends Period:
periodMultiplier int (1..1)

View File

@@ -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.">

View File

@@ -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.">

View File

@@ -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.">

View File

@@ -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)
} deriving (Show, Eq)

View File

@@ -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)
deriving (Eq, Show)

View File

@@ -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)
data Cardinality = Bounds (Integer, Integer)
| OneBound Integer
| NoBounds
deriving Show

View File

@@ -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
@@ -39,23 +37,3 @@ enumNameParser =
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
]

View File

@@ -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 =
@@ -203,17 +203,3 @@ 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"

View File

@@ -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")
]

View File

@@ -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)
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) <> "]"

View File

@@ -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"

View File

@@ -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 _ [] = []
@@ -79,80 +30,3 @@ 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"

View File

@@ -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

View File

@@ -1,4 +0,0 @@
enum PeriodEnum: <"description">
D displayName "day" <"Day">
M displayName "month" <"Month">
Y displayName "year" <"Year">

View File

@@ -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.">

View File

@@ -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"

View File

@@ -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
}