radumaco/RosettaHaskellCompiler
1
0
Fork 0
mirror of https://github.com/macocianradu/RosettaHaskellCompiler.git synced 2026-03-18 13:00:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

added type checker

Browse Source
This commit is contained in:
macocianradu
2021-10-27 15:18:02 +02:00
parent 51c625b74b
commit 9437c6bd7a
8 changed files with 218 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
RosettaParser.cabal
View File

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

63
app/Main.hs
View File

@@ -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,38 +19,83 @@ 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()
testType = do
testTypeParser :: IO()
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
putStrLn $ printType typ
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)
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"
]

1
package.yaml
View File

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

13
src/Model/Type.hs
View File

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

24
src/Parser/Expression.hs
View File

@@ -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 ------------------------------
--------------------------------------------
@@ -200,4 +215,5 @@ 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"
testFail = parseTest expressionParser "if[1,as]thenxandoelseaora"
testOr = parseTest expressionParser "a or b"

6
src/PrettyPrinter/Type.hs
View File

@@ -5,18 +5,14 @@ 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) =
printDescription description

126
src/Semantic/TypeChecker.hs Normal file
View File

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

19
src/TestFiles/testType.rosetta
View File

@@ -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">
testSome testSomeType (1..*) <"Test some">
testMaybeOne testZeroOneType (0..1) <"Test zero or one">
testMany TestType (0..*) <"Test many">
testSome TestSomeType (1..*) <"Test some">
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.">
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">
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.">