diff --git a/resources/Rosetta/test-multiple.rosetta b/resources/Rosetta/test-multiple.rosetta index 7e37103..0984104 100644 --- a/resources/Rosetta/test-multiple.rosetta +++ b/resources/Rosetta/test-multiple.rosetta @@ -11,6 +11,14 @@ type Obs: exchangeRate ExchangeRate (0..1) condition: one-of +func Konst: + inputs: + constant number (1..1) + output: + observable Obs (1..1) + assign-output observable -> constant: + constant + func ExchangeRateFunc: inputs: from int (1..1) @@ -78,7 +86,7 @@ func MkExpired: func MkOne: inputs: - currency UnitType (1..1) + currency int (1..1) output: contract Contract (1..1) assign-output contract -> one -> currency: @@ -104,4 +112,99 @@ func MkBoth: assign-output contract -> both -> left: left assign-output contract -> both -> right: - right \ No newline at end of file + right + +func MkThereafter: + inputs: + earlier Contract (1..1) + later Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> thereafter -> earlier: + earlier + assign-output contract -> thereafter -> later: + later + +func MkGive: + inputs: + subContract Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> give -> contract: + subContract + +func MkTruncate: + inputs: + truncateTo string (1..1) + subContract Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> truncate -> contract: + subContract + assign-output contract -> truncate -> expiryDate: + truncateTo + +func MkScale: + inputs: + observable Obs (1..1) + subContract Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> scale -> contract: + subContract + assign-output contract -> scale -> observable: + observable + +func MkGet: + inputs: + subContract Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> get -> contract: + subContract + +func MkAnytime: + inputs: + subContract Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> anytime -> contract: + subContract + +func MkAnd: + inputs: + left Contract (1..1) + right Contract (1..1) + output: + contract Contract (1..1) + assign-output contract: + MkThereafter(MkBoth(left,right),MkOr(left,right)) + +func ZeroCouponBond: + inputs: + maturesOn string (1..1) <"Date the bond matures on"> + amount number (1..1) <"Amount of the bond is worth"> + currency int (1..1) <"Unit the bond is denoted in"> + output: + contract Contract (1..1) + assign-output contract: + MkGet (MkTruncate(maturesOn, MkScale(Konst(amount),MkOne(currency)))) + +func Perhaps: + inputs: + endDate string (1..1) + contract Contract (1..1) + output: + perhaps Contract (1..1) + assign-output perhaps: + MkTruncate(endDate,MkOr(contract,MkZero())) + +func EuropeanOption: + inputs: + endDate string (1..1) + contract Contract (1..1) + output: + option Contract (1..1) + + assign-output option: + MkGet(Perhaps(endDate,contract)) \ No newline at end of file diff --git a/resources/Rosetta/test-period.rosetta b/resources/Rosetta/test-period.rosetta index e745c89..237a2e1 100644 --- a/resources/Rosetta/test-period.rosetta +++ b/resources/Rosetta/test-period.rosetta @@ -1,13 +1,21 @@ namespace test.period : <"Something"> version "${version.ok}" -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: <"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 boolean (0..*) <"Test many"> - testSome boolean (1..*) <"Test some"> - testMaybeOne int (0..1) <"Test zero or one"> +type ExchangeRate: + from int (1..1) + to int (1..1) + + +type Obs: + constant number (0..1) + exchangeRate ExchangeRate (0..1) + condition: one-of + +func Konst: + inputs: + constant number (1..1) + output: + observable Obs (1..1) + assign-output observable -> constant: + constant \ No newline at end of file diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 0f0a7a0..f9c796a 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -58,6 +58,18 @@ data ExplicitExpression = ExplicitEmpty | ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion} | ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion} +changeCoercion :: ExplicitExpression -> Coercion -> ExplicitExpression +changeCoercion ExplicitEmpty _ = ExplicitEmpty +changeCoercion (ExplicitVariable n _) c = ExplicitVariable n c +changeCoercion (Value n _) c = Value n c +changeCoercion (ExplicitList e) _ = ExplicitList e +changeCoercion (ExplicitKeyword n) _ = ExplicitKeyword n +changeCoercion (ExplicitParens e) _ = ExplicitParens e +changeCoercion (ExplicitPath s n _) c = ExplicitPath s n c +changeCoercion (ExplicitFunction n args _) c = ExplicitFunction n args c +changeCoercion (ExplicitIfSimple cond block _) c = ExplicitIfSimple cond block c +changeCoercion (ExplicitIfElse cond block block2 _) c = ExplicitIfElse cond block block2 c + instance Show ExplicitExpression where show (ExplicitVariable name coer) = show $ "Variable: " ++ name show (Value name coer) = show $ "Value: " ++ name @@ -139,7 +151,8 @@ toHaskell :: Type -> Type toHaskell a | typeName a == "int" = BasicType "Integer" | typeName a == "boolean" = BasicType "Boolean" - | typeName a == "real" = BasicType "Double" + | typeName a == "number" = BasicType "Double" + | typeName a == "string" = BasicType "String" | otherwise = a coercionType :: [TypeCoercion] -> Type diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 1ecddf9..8983463 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -69,7 +69,10 @@ listParser = variableParser :: Parser Expression variableParser = do - Variable <$> camelNameParser + name <- camelNameParser + if name == "endDate," then error "lool" + else return $ Variable name + --Variable <$> camelNameParser -- |Parses an integer in Rosetta into an Expression integerParser :: Parser Expression diff --git a/src/PrettyPrinter/Expression.hs b/src/PrettyPrinter/Expression.hs index 238f109..613b45e 100644 --- a/src/PrettyPrinter/Expression.hs +++ b/src/PrettyPrinter/Expression.hs @@ -5,45 +5,45 @@ module PrettyPrinter.Expression where import Model.Type import Prettyprinter import Semantic.ExpressionChecker(coercionIncluded) +import Utils.Utils -printExpression :: ExplicitExpression -> Coercion -> Doc a -printExpression ExplicitEmpty _ = "[]" -printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of - Left err -> error $ show coer ++ "//" ++ show out --err - Right c -> printCoercion c $ pretty name -printExpression (Value s coer) out = case coer `coercionIncluded` out of - Left err -> error $ show err - Right c -> printCoercion c $ pretty s -printExpression (ExplicitKeyword k) out = pretty k -printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")" -printExpression (ExplicitList ex) out = list [printExpression x out | x <- ex] -printExpression (ExplicitPath ex1 ex2 returnCoerce) out = printCoercion (returnCoercion ex1) (printExpression ex1 (returnCoercion ex1)) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2 out) -printExpression (ExplicitFunction "exists" args returnCoerce) out = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) -printExpression (ExplicitFunction "is absent" args returnCoerce) out = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) -printExpression (ExplicitFunction "single exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> "1" -printExpression (ExplicitFunction "multiple exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> ">" <+> "1" -printExpression (ExplicitFunction "count" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) +printExpression :: ExplicitExpression -> Doc a +printExpression ExplicitEmpty = "[]" +printExpression (ExplicitVariable name coer) = printCoercion coer $ pretty name +printExpression (Value s coer) = printCoercion coer $ pretty s +printExpression (ExplicitKeyword k) = pretty k +printExpression (ExplicitParens ex) = "(" <> printExpression ex <> ")" +printExpression (ExplicitList ex) = list [printExpression x | x <- ex] +printExpression (ExplicitPath ex1 ex2 returnCoerce) = printCoercion (returnCoercion ex1) (printExpression ex1) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2) +printExpression (ExplicitFunction "exists" args returnCoerce) = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) +printExpression (ExplicitFunction "is absent" args returnCoerce) = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) +printExpression (ExplicitFunction "single exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> "1" +printExpression (ExplicitFunction "multiple exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> ">" <+> "1" +printExpression (ExplicitFunction "count" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) -- Equality expressions -- [a] a all = -- any <> -printExpression (ExplicitFunction "=" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) -printExpression (ExplicitFunction "<>" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) -printExpression (ExplicitFunction "any =" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) -printExpression (ExplicitFunction "all <>" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) -printExpression (ExplicitFunction "all =" args returnCoerce) out = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) -printExpression (ExplicitFunction "and" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) -printExpression (ExplicitFunction "or" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) -printExpression (ExplicitFunction name args returnCoerce) out = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e out | (e, c) <- args]) -printExpression (ExplicitIfSimple cond thenBlock returnCoercion) out = - "if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+> - "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+> - "else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` out of +printExpression (ExplicitFunction "=" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) +printExpression (ExplicitFunction "<>" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) +printExpression (ExplicitFunction "any =" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) +printExpression (ExplicitFunction "all <>" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) +printExpression (ExplicitFunction "all =" args returnCoerce) = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) +printExpression (ExplicitFunction "and" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) +printExpression (ExplicitFunction "or" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) +printExpression (ExplicitFunction name args returnCoerce) = + if null printedArgs then pretty (uncapitalize name) + else "(" <> pretty (uncapitalize name) <+> printCoercion returnCoerce (hsep printedArgs) <> ")" + where printedArgs = zipWith printCoercion [c | (e,c) <- args] [printExpression e | (e, c) <- args] +printExpression (ExplicitIfSimple cond thenBlock returnCoercion) = + "if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+> + "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+> + "else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` returnCoercion of Left err -> error $ show err Right c -> printCoercion c emptyDoc -printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) out = - "if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+> - "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+> - "else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock) out) +printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) = + "if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+> + "then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+> + "else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock)) -- |Converts a coercion into a haskell string printCoercion :: Coercion -> Doc a -> Doc a diff --git a/src/PrettyPrinter/Function.hs b/src/PrettyPrinter/Function.hs index 302deaf..3179b12 100644 --- a/src/PrettyPrinter/Function.hs +++ b/src/PrettyPrinter/Function.hs @@ -8,7 +8,7 @@ import Model.Function import PrettyPrinter.General import PrettyPrinter.Type import Model.Type -import Utils.Utils (uncapitalize) +import Utils.Utils (capitalize, uncapitalize) {- Consider all assignments as trees @@ -42,7 +42,7 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod printFunctionBody :: ExplicitFunction -> Doc a printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) = pretty name <+> printVariableNames inp <+> "=" <+> - printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]) (returnCoercion (fst $ head ex)) + printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]) --error $ show $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex] @@ -55,15 +55,19 @@ printFunctionSignature (MakeFunctionSignature name description inputs output) = prettyPrintType :: [Doc x] -> Doc x prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->") -printAssignmentTree :: AssignmentTree -> Coercion -> Doc a -printAssignmentTree (AssignmentLeaf exp) coer = printExpression exp coer -printAssignmentTree (AssignmentNode var typ c) coer +printAssignmentTree :: AssignmentTree -> Doc a +printAssignmentTree (AssignmentLeaf exp) = printExpression exp +printAssignmentTree (AssignmentNode var typ c) | length c == 1 = case head c of - AssignmentLeaf e -> printConstructor typ <+> "(" <+> printAssignmentTree (head c) coer <> ")" - AssignmentNode v t _ -> printConstructor typ <> printConstructor t <+> "(" <+> printAssignmentTree (head c) coer <> ")" + AssignmentLeaf e -> printAssignmentTree (head c) + AssignmentNode v t _ -> printConstructor typ <> pretty (capitalize v) <+> "(" <> printAssignmentTree (head c) <> ")" | otherwise = case typ of - MakeType t _ _ _ _ -> "Make" <> pretty t <+> group (sep [printAssignmentTree child coer | child <- c]) - BasicType _ -> sep [printAssignmentTree child coer | child <- c] + MakeType t _ _ _ _ -> "Make" <> pretty t <+> "{" <> hsep (punctuate "," [pretty (uncapitalize t) <> getVarName child <+> "=" <+> printAssignmentTree child | child <- c]) <> "}" + BasicType _ -> sep ["(" <> printAssignmentTree child <> ")" | child <- c] + +getVarName :: AssignmentTree -> Doc a +getVarName (AssignmentLeaf _) = emptyDoc +getVarName (AssignmentNode var _ _) = pretty (capitalize var) mergeAssignmentTrees :: [AssignmentTree] -> [AssignmentTree] mergeAssignmentTrees [] = [] diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index f4b2d9c..a0c4dcc 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -254,7 +254,7 @@ getTypeAttributes (defT : ts) t | typeName defT == typeName t = [MakeTypeAttribute {attributeName = attributeName attr, attributeType = toHaskell (attributeType attr), - Model.Type.cardinality = Model.Type.cardinality attr, + Model.Type.cardinality = if MakeCondition Nothing (Keyword "one-of") `elem` conditions defT then Bounds (1,1) else Model.Type.cardinality attr, attributeDescription = attributeDescription attr} | attr <- typeAttributes defT] | otherwise = getTypeAttributes ts t diff --git a/src/Semantic/FunctionChecker.hs b/src/Semantic/FunctionChecker.hs index 453b6fc..a859fab 100644 --- a/src/Semantic/FunctionChecker.hs +++ b/src/Semantic/FunctionChecker.hs @@ -24,12 +24,15 @@ checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name checkAssignment :: [Type] -> [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)] checkAssignment _ _ [] = Right [] -checkAssignment defT symbs ((assign, ex): assigns) = +checkAssignment defT symbs ((assign, ex): assigns) = case checkExpression defT (tail symbs) ex of Left err -> Left [err] -- Here we use only tail symbs, beacuse the head of the symbol table is the out variable, and that can't be used in the expression body Right checkedExp -> case checkExpression defT symbs assign of Left err -> Left [err] Right checkedA -> case checkAssignment defT symbs assigns of - Left err -> Left err - Right checked -> Right $ (checkedA, checkedExp) : checked \ No newline at end of file + Left err -> Left err + -- Add a final explicit transformation to match the expected output + Right checked -> case returnCoercion checkedExp `coercionIncluded` returnCoercion checkedA of + Left err -> Left [err] + Right c -> Right $ (checkedA, changeCoercion checkedExp c) : checked \ No newline at end of file diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index f246ee2..be6132b 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -47,27 +47,6 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) = Left err -> Left err : checkAttributes definedTypes as Right checked -> Right (MakeTypeAttribute name checked crd desc) : checkAttributes definedTypes as -populateAttributeType :: [Type] -> [Type] -> TypeAttribute -> Either TypeCheckError TypeAttribute -populateAttributeType _ _ (MakeTypeAttribute n (MakeType "int" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Integer") c d -populateAttributeType _ _ (MakeTypeAttribute n (MakeType "string" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "String") c d -populateAttributeType _ _ (MakeTypeAttribute n (MakeType "number" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Double") c d -populateAttributeType _ _ (MakeTypeAttribute n (MakeType "boolean" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Bool") c d -populateAttributeType _ _ (MakeTypeAttribute n (MakeType "time" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Time") c d -populateAttributeType _ _ (MakeTypeAttribute n (BasicType t) c d) = Right $ MakeTypeAttribute n (BasicType t) c d -populateAttributeType _ [] t = Left $ UndefinedType $ typeName $ attributeType t -populateAttributeType t (definedT : ts) typ - | definedT == attributeType typ = - let populatedAttr = map (populateAttributeType t t) (typeAttributes definedT) - in - if null $ lefts populatedAttr - then Right $ MakeTypeAttribute - (attributeName typ) - (MakeType (typeName definedT) (superType definedT) (typeDescription definedT) (rights populatedAttr) (conditions definedT)) - (cardinality typ) - (attributeDescription typ) - else Left $ head $ lefts populatedAttr - | otherwise = populateAttributeType t ts typ - -- |Checks whether a type is predefined or in the symbol table checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type checkAttributeType [] t = Left $ UndefinedType $ typeName t