diff --git a/app/Main.hs b/app/Main.hs index bd96b90..8c55433 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,6 +19,7 @@ import Model.Enum import Data.Either -- :set args resources/testAll.rosetta resources/Generated/testAll.hs +-- :l resources/Generated/testAll.hs -- |Reads a rosetta string from the first input argument and writes a haskell output to the file given as a second argument main :: IO () main = do diff --git a/resources/testAll.rosetta b/resources/testAll.rosetta index 8a04822..0172897 100644 --- a/resources/testAll.rosetta +++ b/resources/testAll.rosetta @@ -3,32 +3,32 @@ enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week M displayName "month" <"Month"> Y displayName "year" <"Year"> -type Period extends Something: <"description"> +type Period extends TestType: <"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) + testType 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."> + testSomeType 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 TestZeroOneType: + testZeroOneType int (1..1) type ObservationPrimitive: - periodMultiplier int (1..1) + observationPrimitive 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 ObservationPrimitive (1..1) + valuationDate ObservationPrimitive (0..1) valuationTime int (0..1) timeType TestType (0..1) determinationMethod ObservationPrimitive (1..*) output: observation ObservationPrimitive (0..1) - assign-output: if equity exists then valuationDate \ No newline at end of file + assign-output: if 2 = 3 then valuationDate \ No newline at end of file diff --git a/src/PrettyPrinter/Function.hs b/src/PrettyPrinter/Function.hs index 4db4b7d..2779931 100644 --- a/src/PrettyPrinter/Function.hs +++ b/src/PrettyPrinter/Function.hs @@ -6,6 +6,7 @@ import Prettyprinter import Model.Function import PrettyPrinter.General import PrettyPrinter.Type +import Model.Type -- show printStatementTree @@ -15,7 +16,7 @@ printFunction f = show $ vcat [printFunctionSignature f, printFunctionBody f] -- |Converts the body of a Function into a haskell valid Doc printFunctionBody :: Function -> Doc a -printFunctionBody (MakeFunction name _ _ _ ex) = pretty name <+> "=" <+> printExpression ex +printFunctionBody (MakeFunction name _ inp _ ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression ex printExpression :: Expression -> Doc a printExpression (Variable s) = pretty s printExpression (Int s) = pretty s @@ -26,11 +27,27 @@ printExpression (Parens ex) = "(" <> printExpression ex <> ")" printExpression (List ex) = list (map printExpression ex) printExpression (Function name ex) = pretty name <> tupled (map printExpression ex) printExpression (PrefixExp name ex) = pretty name <+> printExpression ex +printExpression (PostfixExp "exists" ex) = "isJust" <+> printExpression ex +printExpression (PostfixExp "is absent" ex) = "isNothing" <+> printExpression ex +printExpression (PostfixExp "single exists" ex) = "length" <+> printExpression ex <+> "==" <+> "1" +printExpression (PostfixExp "multiple exists" ex) = "length" <+> printExpression ex <+> ">" <+> "1" +printExpression (PostfixExp "count" ex) = "length" <+> printExpression ex printExpression (PostfixExp name ex) = pretty name <+> printExpression ex +-- Equality expressions +printExpression (InfixExp "=" ex1 ex2) = printExpression ex1 <+> "==" <+> printExpression ex2 +printExpression (InfixExp "<>" ex1 ex2) = printExpression ex1 <+> "/=" <+> printExpression ex2 +printExpression (InfixExp "any =" ex1 ex2) = printExpression ex2 <+> "`elem`" <+> printExpression ex1 +printExpression (InfixExp "all <>" ex1 ex2) = printExpression ex2 <+> "`notElem`" <+> printExpression ex1 +printExpression (InfixExp "and" ex1 ex2) = printExpression ex1 <+> "&&" <+> printExpression ex2 +printExpression (InfixExp "or" ex1 ex2) = printExpression ex1 <+> "||" <+> printExpression ex2 printExpression (InfixExp name ex1 ex2) = printExpression ex1 <+> pretty name <+> printExpression ex2 printExpression (IfSimple cond ex) = "if" <+> printExpression cond <+> "then" <+> printExpression ex <+> "else" <+> "Nothing" printExpression (IfElse cond ex1 ex2) = "if" <+> printExpression cond <+> "then" <+> printExpression ex1 <+> "else" <+> printExpression ex2 +-- |Converts a list of type attributes to a Doc with a list of variable names +printVariableNames :: [TypeAttribute] -> Doc a +printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars) + -- |Converts a function into a haskell valid Doc representing the signature of the function printFunctionSignature :: Function -> Doc a printFunctionSignature (MakeFunction name description inputs output _) = diff --git a/src/Semantic/FunctionChecker.hs b/src/Semantic/FunctionChecker.hs index adfb4b7..4830cc4 100644 --- a/src/Semantic/FunctionChecker.hs +++ b/src/Semantic/FunctionChecker.hs @@ -5,13 +5,14 @@ import Model.Type import Semantic.ExpressionChecker import Semantic.TypeChecker import Data.Either +import Data.Char -- |Checks if all the inputs and the out of a function call have valid types, and then checks that the assign-output expression is valid checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] Function checkFunction (definedTypes, definedFunctions) (MakeFunction name desc inp out ex) | isRight checkedEx && isRight checkedOut && null (lefts checkedIn) = case typeMatch (attributeType $ fromRightUnsafe checkedOut, Model.Type.cardinality out) (fromRightUnsafe checkedEx) of - Right _ -> Right $ MakeFunction name desc (rights checkedIn) (fromRightUnsafe checkedOut) ex + Right _ -> Right $ MakeFunction (toLower (head name) : tail name) desc (rights checkedIn) (fromRightUnsafe checkedOut) ex Left err -> Left [err] | otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx] where diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index 9aff846..c8f7d46 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -18,12 +18,21 @@ data TypeCheckError = -- |Checks whether a data type is valid checkType :: [Type] -> Type -> Either [TypeCheckError] Type checkType definedTypes (MakeType name super desc attr) - | null (lefts checkedAttr) = Right $ MakeType name super desc (rights checkedAttr) + | null (lefts checkedAttr) = case checkSuper definedTypes super of + Right superChecked -> Right $ MakeType name superChecked desc (rights checkedAttr) + Left err -> Left [err] | otherwise = Left $ lefts checkedAttr - where checkedAttr = checkAttributes definedTypes attr + where checkedAttr = checkAttributes definedTypes attr checkType _ (BasicType b) = Right (BasicType b) +checkSuper :: [Type] -> Maybe Type -> Either TypeCheckError (Maybe Type) +checkSuper _ Nothing = Right Nothing +checkSuper definedTypes (Just super) = + case checkAttributeType definedTypes super of + Right sup -> Right (Just sup) + Left err -> Left err + -- |Checks whether all the types of the attributes of a data type are already defined checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute] checkAttributes _ [] = []