diff --git a/.gitignore b/.gitignore index f3d6ca7..9e2fa7e 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ cabal.project.local~ .HTF/ .ghc.environment.* .idea/ +/resources/Generated/ diff --git a/RosettaParser.cabal b/RosettaParser.cabal index b2b1726..ce0482e 100644 --- a/RosettaParser.cabal +++ b/RosettaParser.cabal @@ -27,6 +27,7 @@ library exposed-modules: Model.Enum Model.Function + Model.RosettaObject Model.Type Parser.Enum Parser.Expression @@ -36,6 +37,7 @@ library PrettyPrinter.Enum PrettyPrinter.Function PrettyPrinter.General + PrettyPrinter.RosettaObject PrettyPrinter.Type Semantic.ExpressionChecker Semantic.TypeChecker diff --git a/RosettaParser.iml b/RosettaParser.iml index 445391a..5e62802 100644 --- a/RosettaParser.iml +++ b/RosettaParser.iml @@ -7,6 +7,7 @@ + diff --git a/app/Main.hs b/app/Main.hs index 79264bb..aba9e81 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,28 +3,84 @@ module Main where import Parser.Enum import Parser.Type import Parser.Function +import Parser.General +import Model.RosettaObject import qualified Data.Text as Text import Text.Megaparsec import PrettyPrinter.Enum import PrettyPrinter.Type import PrettyPrinter.Function import Semantic.TypeChecker +import Semantic.ExpressionChecker import Model.Function import Model.Type +import System.Environment.Blank (getArgs) +import Model.Enum +import Data.Either +-- :set args resources/testAll.rosetta resources/Generated/testAll.hs main :: IO () main = do - rosettaString <- readFile "app/testFile.rosetta" - putStrLn "rosetta String: " - putStrLn rosettaString - putStrLn "\nFinal enum: \n" - case parse enumParser "" (Text.pack rosettaString) of + args <- getArgs + rosettaString <- readFile $ head args + case parse rosettaParser "" (Text.pack rosettaString) of Left errorBundle -> print (errorBundlePretty errorBundle) - Right enum -> putStrLn $ printEnum enum + Right objs -> do + putStrLn $ printObjects (definedTypes, definedFunctions) objs + where + definedFunctions = addNewFunctions (definedTypes, defaultMap) objs + definedTypes = addNewTypes [] objs + +printObjects :: ([Type], [Symbol]) -> [RosettaObject] -> String +printObjects (t, s) objs + | null (lefts finalString) = concat $ rights finalString + | otherwise = error $ show $ lefts finalString + where finalString = map (printObject (t, s)) objs + +printObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] String +printObject (definedTypes, _) (TypeObject t) + | isRight checked = Right $ printType t + | otherwise = Left $ fromLeftUnsafe checked + where checked = checkType definedTypes t +printObject _ (EnumObject e) = Right $ printEnum e +printObject (_, definedFunctions) (FunctionObject (MakeFunction name desc inp out ex)) + | isRight checked = Right $ printFunction (MakeFunction name desc inp out ex) + | otherwise = Left [fromLeftUnsafe checked] + where + checked = checkExpression definedFunctions ex + +addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> [Symbol] +addNewFunctions (_, s) [] = s +addNewFunctions (t, s) ((FunctionObject f):os) + | isRight definedFunctions = fromRightUnsafe definedFunctions + | otherwise = error $ show $ fromLeftUnsafe definedFunctions + where definedFunctions = addFunction (t, addNewFunctions (t, s) os) f +addNewFunctions (t, s) (_:os) = addNewFunctions (t, s) os + +addNewTypes :: [Type] -> [RosettaObject] -> [Type] +addNewTypes l [] = l +addNewTypes defined (TypeObject o: os) = addDefinedTypes (addNewTypes defined os) [o] +addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addDefinedTypes (addNewTypes defined os) [MakeType name Nothing Nothing []] +addNewTypes defined (_ :os) = addNewTypes defined os + +rosettaParser :: Parser [RosettaObject] +rosettaParser = many (try parseEnum <|> try parseType <|> try parseFunction) <* eof + +parseEnum :: Parser RosettaObject +parseEnum = do + EnumObject <$> enumParser + +parseType :: Parser RosettaObject +parseType = do + TypeObject <$> typeParser + +parseFunction :: Parser RosettaObject +parseFunction = do + FunctionObject <$> functionParser testEnum :: IO() testEnum = do - rosettaString <- readFile "resources/Enums/testEnum5.rosetta" + rosettaString <- readFile "resources/Enums/testEnum1.rosetta" case parse enumParser "" (Text.pack rosettaString) of Left errorBundle -> print errorBundle Right enum -> @@ -61,5 +117,5 @@ testFunc = do Right fun -> do print $ printFunctionSignature fun - print (assignments fun) + print (assignment fun) writeFile "resources/Generated/generatedFunction.hs" (show $ printFunctionSignature fun) \ No newline at end of file diff --git a/resources/Types/testType1.rosetta b/resources/Types/testType1.rosetta index 7af2ef0..4b56590 100644 --- a/resources/Types/testType1.rosetta +++ b/resources/Types/testType1.rosetta @@ -1,4 +1,4 @@ -type Period: <"description"> +type Period extends Something: <"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"> diff --git a/resources/testAll.rosetta b/resources/testAll.rosetta new file mode 100644 index 0000000..292504f --- /dev/null +++ b/resources/testAll.rosetta @@ -0,0 +1,34 @@ +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"> + +type Period extends Something: <"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 TestType: + periodMultiplier int (1..1) + +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 extends Period: + periodMultiplier int (1..1) + +type ObservationPrimitive: + periodMultiplier int (1..1) + +func EquityPriceObservation: <"Function specification for the observation of an equity price, based on the attributes of the 'EquityValuation' class."> + inputs: + equity int (1..1) + valuationDate int (1..1) + valuationTime int (0..1) + timeType TestType (0..1) + determinationMethod ObservationPrimitive (1..*) + output: + observation ObservationPrimitive (1..1) + + assign-output: if equity exists then valuationDate \ No newline at end of file diff --git a/resources/testFunction.rosetta b/resources/testFunction.rosetta index bc20ce6..6d5ab45 100644 --- a/resources/testFunction.rosetta +++ b/resources/testFunction.rosetta @@ -8,5 +8,4 @@ func EquityPriceObservation: <"Function specification for the observation of an output: observation ObservationPrimitive (1..1) - assign-output - observation: if asd exists then var2 \ No newline at end of file + assign-output: if asd exists then var2 \ No newline at end of file diff --git a/src/Model/Function.hs b/src/Model/Function.hs index 501e17d..fdcb9b2 100644 --- a/src/Model/Function.hs +++ b/src/Model/Function.hs @@ -8,7 +8,7 @@ data Function = functionDescription :: Maybe String, inputParameters :: [TypeAttribute], outputParameter :: TypeAttribute, - assignments :: [(Expression, Expression)] + assignment :: Expression } deriving (Show) diff --git a/src/Model/RosettaObject.hs b/src/Model/RosettaObject.hs new file mode 100644 index 0000000..8a8e315 --- /dev/null +++ b/src/Model/RosettaObject.hs @@ -0,0 +1,10 @@ +module Model.RosettaObject where + +import Model.Enum +import Model.Function +import Model.Type + +data RosettaObject = + EnumObject EnumType + | TypeObject Type + | FunctionObject Function \ No newline at end of file diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 5bb5988..20d1abe 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -29,7 +29,6 @@ data TypeAttribute = MakeTypeAttribute { attributeDescription :: Maybe String } deriving (Show) ---TODO use bounded class data Cardinality = Bounds (Integer, Integer) | OneBound Integer | NoBounds diff --git a/src/Parser/Enum.hs b/src/Parser/Enum.hs index aea15ba..bb391d9 100755 --- a/src/Parser/Enum.hs +++ b/src/Parser/Enum.hs @@ -10,7 +10,7 @@ import Model.Enum enumParser :: Parser EnumType enumParser = do - eName <- enumNameParser + eName <- try enumNameParser eDescription <- optional descriptionParser values <- some enumValueParser return (MakeEnum eName eDescription values) @@ -18,7 +18,7 @@ enumParser = enumValueParser :: Parser EnumValue enumValueParser = do - vName <- nameParser + vName <- try nameParser dName <- optional enumValueDisplayNameParser vDescription <- optional descriptionParser return (MakeEnumValue vName vDescription dName) diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index a54a002..8e0c5c2 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -193,7 +193,7 @@ reverseExpression e = e precedence :: String -> Int precedence "or" = 1 -precedence "and" = 1 +precedence "and" = 10 precedence "+" = 2 precedence "-" = 2 precedence "*" = 3 diff --git a/src/Parser/Function.hs b/src/Parser/Function.hs index 651006c..30f26bd 100644 --- a/src/Parser/Function.hs +++ b/src/Parser/Function.hs @@ -14,22 +14,19 @@ functionParser :: Parser Function functionParser = do _ <- lexeme $ string "func" - fName <- pascalNameParser + fName <- try pascalNameParser _ <- lexeme $ char ':' fDescription <- optional descriptionParser fInput <- inputAttributesParser fOutput <- outputAttributeParser - fAssignments <- many assignmentParser - return (MakeFunction fName fDescription fInput fOutput fAssignments) + MakeFunction fName fDescription fInput fOutput <$> assignmentParser -assignmentParser :: Parser (Expression, Expression) +assignmentParser :: Parser Expression assignmentParser = do _ <- lexeme $ string "assign-output" - name <- expressionParser _ <- lexeme $ char ':' - expr <- expressionParser - return (name, expr) + expressionParser inputAttributesParser :: Parser [TypeAttribute] inputAttributesParser = @@ -46,8 +43,8 @@ outputAttributeParser = attributeParser :: Parser TypeAttribute attributeParser = do - nam <- camelNameParser - typ <- pascalNameParser <|> camelNameParser + nam <- try camelNameParser + typ <- try (pascalNameParser <|> camelNameParser) crd <- cardinalityParser desc <- optional descriptionParser return $ MakeTypeAttribute nam (MakeType typ Nothing Nothing []) crd desc diff --git a/src/Parser/General.hs b/src/Parser/General.hs index e18250b..481fcc4 100755 --- a/src/Parser/General.hs +++ b/src/Parser/General.hs @@ -27,19 +27,33 @@ pascalNameParser :: Parser String pascalNameParser = do first <- upperChar - rest <- lexeme $ many (letterChar <|> digitChar <|> char '_') - return (first : rest) + rest <- lexeme $ many allowedChars + if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name") camelNameParser :: Parser String camelNameParser = do first <- lowerChar - rest <- lexeme $ many (letterChar <|> digitChar <|> char '_') - return (first : rest) + rest <- lexeme $ many allowedChars + if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name") nameParser :: Parser String nameParser = do first <- letterChar <|> char '_' - rest <- lexeme $ many (letterChar <|> digitChar <|> char '_') - return (first:rest) \ No newline at end of file + rest <- lexeme $ many allowedChars + if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name") + +allowedChars :: Parser Char +allowedChars = letterChar <|> digitChar <|> char '_' + +restrictedNames :: [String] +restrictedNames = [ + "displayName", + "enum", + "func", + "type", + "extends", + "inputs", + "output" + ] \ No newline at end of file diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index a17b387..67d8edc 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -10,7 +10,7 @@ import Parser.General typeParser :: Parser Type typeParser = do - tName <- typeNameParser + tName <- try typeNameParser tSuper <- optional superTypeParser _ <- lexeme $ char ':' tDescription <- optional descriptionParser @@ -27,8 +27,8 @@ superTypeParser = typeAttributeParser :: Parser TypeAttribute typeAttributeParser = do - aName <- camelNameParser - aType <- nameParser + aName <- try camelNameParser + aType <- try nameParser card <- cardinalityParser desc <- optional descriptionParser return (MakeTypeAttribute aName (MakeType aType Nothing Nothing []) card desc) diff --git a/src/PrettyPrinter/Function.hs b/src/PrettyPrinter/Function.hs index ab1e2da..7475095 100644 --- a/src/PrettyPrinter/Function.hs +++ b/src/PrettyPrinter/Function.hs @@ -9,6 +9,9 @@ import PrettyPrinter.Type -- show printStatementTree +printFunction :: Function -> String +printFunction = show . printFunctionSignature + printFunctionSignature :: Function -> Doc a printFunctionSignature (MakeFunction name description inputs output _) = printDescription description (pretty name <+> prettyPrintType (Prelude.map printCardinality (inputs ++ [output]))) diff --git a/src/PrettyPrinter/RosettaObject.hs b/src/PrettyPrinter/RosettaObject.hs new file mode 100644 index 0000000..82d67a5 --- /dev/null +++ b/src/PrettyPrinter/RosettaObject.hs @@ -0,0 +1,11 @@ +module PrettyPrinter.RosettaObject where + +import Model.RosettaObject +import PrettyPrinter.Enum +import PrettyPrinter.Function +import PrettyPrinter.Type + +printRosettaObject :: RosettaObject -> String +printRosettaObject (EnumObject a) = printEnum a +printRosettaObject (TypeObject a) = printType a +printRosettaObject (FunctionObject a) = printFunction a \ No newline at end of file diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index f108e56..ee649a6 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -7,15 +7,24 @@ import PrettyPrinter.General 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), "}", ""]) +printType (MakeType name (Just (MakeType super _ _ _)) description attributes) = printType (MakeType name Nothing description (superToAttribute super:attributes)) +printType (MakeType _ (Just (BasicType _)) _ _) = error "Can't extend basic types" +printType (MakeType name Nothing description attributes) = + show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes attributes), "}", ""]) printType (BasicType name) = show $ pretty name +--printSuperType :: Maybe Type -> Doc a +--printSuperType (Just (MakeType name _ _ _)) = "super" <+> "::" <+> pretty name +--printSuperType (Just (BasicType _)) = error "Can't extend basic types" +--printSuperType Nothing = emptyDoc + +superToAttribute :: String -> TypeAttribute +superToAttribute name = MakeTypeAttribute "super" (MakeType name Nothing Nothing []) (Bounds (1, 1)) (Just "Pointer to super class") + 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) = diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index fb3d1f6..c828896 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -51,7 +51,21 @@ defaultMap = [ Func "count" [BasicType "Any"] (BasicType "Integer") ] - + +addFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] [Symbol] +addFunction (definedTypes, definedSymbols) (MakeFunction name _ inps out _) + | null (lefts checkedInputs) && isRight checkedOutput = Right $ Func name (map attributeType (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput) : allSymbols + | isLeft checkedOutput = Left [fromLeftUnsafe checkedOutput] + | otherwise = Left $ lefts checkedInputs + where + checkedInputs = checkAttributes definedTypes inps + checkedOutput = head $ checkAttributes definedTypes [out] + allSymbols = addVariables definedSymbols inps + +addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol] +addVariables s [] = s +addVariables s ((MakeTypeAttribute name typ _ _) : vars) = Var name typ : addVariables s vars + checkExpression :: [Symbol] -> Expression -> Either TypeCheckError Type checkExpression symbolMap (Variable var) = findVarType var symbolMap checkExpression _ (Int _) = Right $ BasicType "Integer" @@ -65,7 +79,7 @@ checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap nam 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 (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex + | isRight condType && isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex | otherwise = Left IfConditionNotBoolean where condType = checkExpression symbolMap cond checkExpression symbolMap (IfElse cond ex1 ex2) @@ -95,7 +109,7 @@ checkList1 symbs (ex : exps) typ checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError Type] -> Either TypeCheckError Type checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap typeName (rights args) ++ "]" checkFunctionCall ((Func n a r):symbolMap) name args - | length right /= length args = Left ErrorInsideFunction + | length right /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args) | name == n && all isRight (zipWith typeMatch a right) = Right r | otherwise = checkFunctionCall symbolMap name args where right = rights args @@ -118,14 +132,4 @@ findVarType var [] = Left $ UndefinedVariable var findVarType x ((Var name typ):symbols) | x == name = Right 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 +findVarType x (_:symbols) = findVarType x symbols \ No newline at end of file diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index efd8f45..9e07bac 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -1,32 +1,53 @@ module Semantic.TypeChecker where import Model.Type +import Data.Either data TypeCheckError = UndefinedType String | IfConditionNotBoolean | IfExpressionsDifferentTypes | UndefinedFunction String - | ErrorInsideFunction + | ErrorInsideFunction String | UndefinedVariable String | TypeMismatch String String deriving (Show) -checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError Type] -checkAttributes _ [] = [] -checkAttributes definedTypes ((MakeTypeAttribute _ name _ _):as) = checkType definedTypes name : checkAttributes definedTypes as +checkType :: [Type] -> Type -> Either [TypeCheckError] Type +checkType definedTypes (MakeType name super desc attr) + | null (lefts checkedAttr) = Right $ MakeType name super desc (rights checkedAttr) + | otherwise = Left $ lefts checkedAttr + where checkedAttr = checkAttributes definedTypes attr +checkType _ (BasicType b) = Right (BasicType b) -checkType :: [Type] -> Type -> Either TypeCheckError Type -checkType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer" -checkType _ (MakeType "string" _ _ _) = Right $ BasicType "String" -checkType _ (MakeType "number" _ _ _) = Right $ BasicType "Double" -checkType _ (MakeType "boolean" _ _ _) = Right $ BasicType "Bool" -checkType _ (MakeType "time" _ _ _) = Right $ BasicType "Time" -checkType definedTypes name +checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute] +checkAttributes _ [] = [] +checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) + | isRight checked = Right (MakeTypeAttribute name (fromRightUnsafe checked) crd desc) : checkAttributes definedTypes as + | otherwise = Left (fromLeftUnsafe checked) : checkAttributes definedTypes as + where checked = checkAttributeType definedTypes typ + +checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type +checkAttributeType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer" +checkAttributeType _ (MakeType "string" _ _ _) = Right $ BasicType "String" +checkAttributeType _ (MakeType "number" _ _ _) = Right $ BasicType "Double" +checkAttributeType _ (MakeType "boolean" _ _ _) = Right $ BasicType "Bool" +checkAttributeType _ (MakeType "time" _ _ _) = Right $ BasicType "Time" +checkAttributeType definedTypes name | name `elem` definedTypes = Right name | otherwise = Left $ 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 \ No newline at end of file +addDefinedTypes l (t:ts) = t : addDefinedTypes l ts + +fromRightUnsafe :: (Show a) => Either a b -> b +fromRightUnsafe x = case x of + Left a -> error ("Value is Left" ++ show a) + 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