From 24bfeea0149594f5a8a0096197fe683790d9d6cc Mon Sep 17 00:00:00 2001 From: Radu Macocian Date: Mon, 8 Aug 2022 03:06:47 +0200 Subject: [PATCH] changed compiler to whole folder --- .gitignore | 3 +- RosettaParser.cabal | 6 + app/Main.hs | 115 ++++- package.yaml | 2 + .../Rosetta/Contracts/contractDSL.rosetta | 3 +- .../Rosetta/Contracts/imports-enum.rosetta | 6 + .../Rosetta/Contracts/imports-type.rosetta | 105 +++++ resources/bkup/contractDSL.rosetta | 416 ++++++++++++++++++ .../Contracts => bkup}/imports-enums.rosetta | 0 .../Contracts => bkup}/imports-types.rosetta | 2 +- src/Model/Type.hs | 5 +- src/Parser/Expression.hs | 25 +- src/Parser/Function.hs | 3 +- src/Parser/Type.hs | 29 +- src/PrettyPrinter/Header.hs | 12 +- src/Semantic/ExpressionChecker.hs | 18 +- src/Utils/Utils.hs | 45 +- 17 files changed, 711 insertions(+), 84 deletions(-) create mode 100644 resources/Rosetta/Contracts/imports-enum.rosetta create mode 100644 resources/Rosetta/Contracts/imports-type.rosetta create mode 100644 resources/bkup/contractDSL.rosetta rename resources/{Rosetta/Contracts => bkup}/imports-enums.rosetta (100%) rename resources/{Rosetta/Contracts => bkup}/imports-types.rosetta (97%) diff --git a/.gitignore b/.gitignore index 3ae5126..ad008ad 100644 --- a/.gitignore +++ b/.gitignore @@ -26,4 +26,5 @@ cabal.project.local~ .vscode/ /resources/Rosetta/Try/ /resources/fxspot.json -/resources/european contract.json \ No newline at end of file +/resources/european contract.json +/resources/CDM/ \ No newline at end of file diff --git a/RosettaParser.cabal b/RosettaParser.cabal index c128d80..c788f83 100644 --- a/RosettaParser.cabal +++ b/RosettaParser.cabal @@ -53,6 +53,8 @@ library src build-depends: base >=4.7 && <5 + , directory + , filepath , megaparsec , mtl , parser-combinators @@ -69,6 +71,8 @@ executable RosettaParser-exe build-depends: RosettaParser , base >=4.7 && <5 + , directory + , filepath , megaparsec , mtl , parser-combinators @@ -93,6 +97,8 @@ test-suite RosettaParser-test build-depends: RosettaParser , base >=4.7 && <5 + , directory + , filepath , hspec , hspec-megaparsec , megaparsec diff --git a/app/Main.hs b/app/Main.hs index 401bf0b..d2fd96d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import Parser.Enum @@ -15,6 +17,7 @@ import Semantic.TypeChecker import Semantic.ExpressionChecker import Semantic.FunctionChecker import Model.Type +import Model.Function import System.Environment.Blank (getArgs) import Model.Enum import Data.Either @@ -23,63 +26,125 @@ import Parser.Header import PrettyPrinter.Header import Data.Tuple (fst, snd) import Data.Void +import System.FilePath import Utils.Utils +import System.Directory +import Data.List import Data.Text (Text) import Parser.Expression (expressionParser) --- :l resources/Generated/ContractDSL.hs resources/Generated/ImportsTypes.hs resources/Generated/ImportsEnums.hs --- :set args resources/Rosetta/Contracts/contractDSL.rosetta +-- :l resources/Generated/ContractDSL.hs resources/Generated/ImportsType.hs resources/Generated/ImportsEnum.hs +-- :set args resources/Rosetta/Contracts/ +-- :set args resources/CDM/ -- |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 args <- getArgs - let mainFile = head args - parseResult <- parseWithImport mainFile - let checked = checkObjects parseResult + let mainFolder = head args + files <- getDirectoryContents mainFolder + parseResult <- parseFolder [mainFolder ++ f | f <- files, f `notElem` [".", ".."]] + let completeFiles = [createSymbolTable f parseResult | f <- parseResult] + let checked = checkObjects completeFiles let headers = fstlst checked let objects = nestedRights $ sndlst checked + --_ <- error $ show [(map typeName t, map symbolName s) | (path, t, s, (head, obj)) <- completeFiles, path == "resources/Rosetta/Contracts/contractDSL.rosetta"] if null $ lefts $ concat $ sndlst checked then let input = pairRights checked in mapM_ generateFile input else error $ show $ lefts $ concat $ sndlst checked -{- |Recursively parse a file and all the imports into a list of headers and objects -The first argument is the default directory, second argument is the file name +{- | Parse the contents of a folder, skip any files without the Rosetta extension +Return a list of Header, Rosettaobject, filename pairs -} -parseWithImport :: String -> IO [(([Type], [Symbol]), (Header, [RosettaObject]))] -parseWithImport file = +parseFolder :: [FilePath] -> IO [(FilePath, Header, [RosettaObject])] +parseFolder [] = return [] +parseFolder (file : files) = do + plain <- readFile file + rest <- parseFolder files + case parseFile plain of + Left errorBundle -> error $ errorBundlePretty errorBundle ++ " on file " ++ file + Right (header, objs) -> + return ((file, header, objs) : rest) + +-- | Create the symbol table for each file from the imported types enums and functions +createSymbolTable :: (FilePath, Header, [RosettaObject]) -> [(FilePath, Header, [RosettaObject])] -> (FilePath, [Type], [Symbol], (Header, [RosettaObject])) +createSymbolTable (file, MakeHeader name desc ver imp, objs) imps = + (file, concat (fstlst imports), concat (sndlst imports), (MakeHeader name desc ver actualImport, objs)) + where + imports = [(getTypes imObjs, getFunctions imObjs) | (_, MakeHeader imName _ _ _, imObjs) <- imps, imName `elem` map getNamespace imp || imName == name] + actualImport = + [removeChar (takeFileName (dropExtension p)) '-' | (p, MakeHeader imName _ _ _, imObjs) <- imps, imName `elem` map getNamespace imp + || (imName == name && p /= file && not ("enum.rosetta" `isSuffixOf` file) && not ("type.rosetta" `isSuffixOf` file && "func.rosetta" `isSuffixOf` p))] + +-- |Get the defined data types from a list of rosetta objects +getTypes :: [RosettaObject] -> [Type] +getTypes [] = [] +getTypes (TypeObject o : os) = o{typeAttributes = map convertAttributeType (typeAttributes o)} : getTypes os +getTypes (EnumObject o : os) = convertEnumToType o : getTypes os +getTypes (FunctionObject o : os) = getTypes os + +convertAttributeType :: TypeAttribute -> TypeAttribute +convertAttributeType (MakeTypeAttribute n (MakeType "int" _ _ _ _) c d) = MakeTypeAttribute n (BasicType "Integer") c d +convertAttributeType (MakeTypeAttribute n (MakeType "string" _ _ _ _) c d) = MakeTypeAttribute n (BasicType "String") c d +convertAttributeType (MakeTypeAttribute n (MakeType "number" _ _ _ _) c d) = MakeTypeAttribute n (BasicType "Double") c d +convertAttributeType (MakeTypeAttribute n (MakeType "boolean" _ _ _ _) c d) = MakeTypeAttribute n (BasicType "Bool") c d +convertAttributeType (MakeTypeAttribute n (MakeType "time" _ _ _ _) c d) = MakeTypeAttribute n (BasicType "Time") c d +convertAttributeType t = t + +getFunctions :: [RosettaObject] -> [Symbol] +getFunctions [] = [] +getFunctions (FunctionObject o : os) = functionToSymbol o : getFunctions os +getFunctions (o : os) = getFunctions os + +functionToSymbol :: Function -> Symbol +functionToSymbol (MakeFunction (MakeFunctionSignature name _ inp out) _ _) = Func name [(attributeType (convertAttributeType i), Model.Type.cardinality i)| i <- inp] (attributeType out, Model.Type.cardinality out) + +{- |Recursively parse a file and all the imports into a list of headers and objects +The first argument is a list of files already parsed (to handle cyclic imports) and the second is the name of the file to be parsed +-} +parseWithImport :: [String] -> String -> IO [(([Type], [Symbol]), (Header, [RosettaObject]))] +parseWithImport files file + | file `elem` files = error $ "cyclic dependency on " ++ file + | otherwise = do plain <- readFile file case parseFile plain of Left errorBundle -> error $ errorBundlePretty errorBundle ++ "on file" ++ file Right (MakeHeader name desc vers imp, objs) -> do - let files = map ((++) (fileDirectory file) . namespaceToName) imp - imports <- mapM parseWithImport files + let modules = map namespaceToName imp + importFiles <- getFiles modules + imports <- mapM (parseWithImport (file : files)) importFiles let importedSymbolTable = fstlst (concat imports) let importedTypes = concat $ fstlst importedSymbolTable let importedFunctions = concat $ sndlst importedSymbolTable case addNewTypes importedTypes objs of - Left errors -> error $ show errors + Left errors -> error $ show errors ++ "\n on file " ++ file Right definedTypes -> case addNewFunctions (definedTypes, importedFunctions) objs of - Left errors -> error $ show errors + Left errors -> error $ show errors ++ "\n on file " ++ file Right definedFunctions -> return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports + +getFiles :: [String] -> IO [String] +getFiles [] = return [] +getFiles (n : ns) + | ".*" `isSuffixOf` n = do + files <- getDirectoryContents $ takeDirectory n + rest <- getFiles ns + return $ [f | f <- files, dropExtension n `isPrefixOf` f] ++ rest + | otherwise = do + files <- getFiles ns + return (n : files) + -- |Parse a file into a list of RosettaObjects parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject]) parseFile plainText = parse rosettaParser "" (Text.pack plainText) --- |Converts a RosettaObject into a plain haskell string --- printObject :: CheckedRosettaObject -> String --- printObject (CheckedTypeObject t) = printType t --- printObject (CheckedFunctionObject f) = printFunction f --- printObject (CheckedEnumObject e) = printEnum e - -- |Checks all the objects from a list -checkObjects :: [(([Type], [Symbol]), (Header, [RosettaObject]))] -> [(Header, [Either [TypeCheckError] CheckedRosettaObject])] +checkObjects :: [(FilePath, [Type], [Symbol], (Header, [RosettaObject]))] -> [((FilePath, Header), [Either [TypeCheckError] CheckedRosettaObject])] checkObjects [] = [] -checkObjects (((definedTypes, definedSymbols), (header, objs)) : rest) = (header, checked) : checkObjects rest +checkObjects ((file, definedTypes, definedSymbols, (header, objs)) : rest) = ((file, header), checked) : checkObjects rest where checked = map (checkObject (definedTypes, definedSymbols)) objs @@ -110,7 +175,7 @@ addNewFunctions (t, s) (_:os) = addNewFunctions (t, s) os -- |Adds new defined types into the symbol table addNewTypes :: [Type] -> [RosettaObject] -> Either [TypeCheckError] [Type] addNewTypes l [] = Right l -addNewTypes defined (TypeObject o: os) = +addNewTypes defined (TypeObject o: os) = case addNewTypes defined os of Left errors -> Left errors Right types -> addDefinedTypes types [o] @@ -140,5 +205,7 @@ parseFunction = do FunctionObject <$> functionParser -- |Generate a new haskell file based on the rosetta objects and header -generateFile :: (Header, [CheckedRosettaObject]) -> IO () -generateFile (header, objects) = writeFile (haskellFileName $ namespace header) (printHeader header ++ concatMap printRosettaObject objects) \ No newline at end of file +generateFile :: ((FilePath, Header), [CheckedRosettaObject]) -> IO () +generateFile ((path, header), objects) = + writeFile (haskellFileName $ dropExtension $ takeFileName path) + (printHeader (dropExtension $ takeFileName path) header ++ concatMap printRosettaObject objects) \ No newline at end of file diff --git a/package.yaml b/package.yaml index cc33771..50d0c0e 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,8 @@ dependencies: - prettyprinter - parser-combinators - text +- filepath +- directory library: source-dirs: src diff --git a/resources/Rosetta/Contracts/contractDSL.rosetta b/resources/Rosetta/Contracts/contractDSL.rosetta index 6ce9261..1db9054 100644 --- a/resources/Rosetta/Contracts/contractDSL.rosetta +++ b/resources/Rosetta/Contracts/contractDSL.rosetta @@ -1,8 +1,7 @@ namespace contractDSL : <"Generic product concepts: quantity, price, economic terms and payout, that are built using template features."> version "${project.version}" -import imports.types.* -import imports.enums.* +import imports.* type Obs: diff --git a/resources/Rosetta/Contracts/imports-enum.rosetta b/resources/Rosetta/Contracts/imports-enum.rosetta new file mode 100644 index 0000000..c93f57e --- /dev/null +++ b/resources/Rosetta/Contracts/imports-enum.rosetta @@ -0,0 +1,6 @@ +namespace imports : <"Enums used for the contract dsl"> +version "${version.ok}" + +enum CounterpartyRoleEnum: + Party1 + Party2 \ No newline at end of file diff --git a/resources/Rosetta/Contracts/imports-type.rosetta b/resources/Rosetta/Contracts/imports-type.rosetta new file mode 100644 index 0000000..291dd64 --- /dev/null +++ b/resources/Rosetta/Contracts/imports-type.rosetta @@ -0,0 +1,105 @@ +namespace imports : <"Types used for the contract dsl"> +version "${version.ok}" + +type Product: + contractualProduct ContractualProduct (0..1) + foreignExchange ForeignExchange (0..1) + + condition: one-of + +type Trade: + tradableProduct TradableProduct (1..1) + +type TradableProduct: + product Product (1..1) + tradeLot TradeLot (1..*) + +type TradeLot: + priceQuantity PriceQuantity (1..*) + +type PriceQuantity: + quantity Quantity (0..*) + +type SettlementTerms: + settlementDate SettlementDate (0..1) + cashSettlementTerms CashSettlementTerms (0..*) + settlementCurrency string (0..1) + unitType UnitType (1..1) + +type CashSettlementTerms: + valuationDate ValuationDate (1..1) + +type ValuationDate: + fxFixingDate FxFixingDate (1..1) + +type FxFixingDate: + fxFixingDate AdjustableOrRelativeDate (1..1) + +type SettlementDate: + valueDate string (1..1) + +type ContractualProduct: + economicTerms EconomicTerms (1..1) + +type EconomicTerms: + payout Payout (1..1) + +type Payout: + optionPayout OptionPayout (0..*) + forwardPayout ForwardPayout (0..*) + cashflow Cashflow (0..*) + +type OptionPayout: + exerciseTerms OptionExercise (1..1) + underlier Product (1..1) + settlementTerms SettlementTerms (0..1) + +type OptionExercise: + optionStyle OptionStyle (1..1) + +type OptionStyle: + europeanExercise EuropeanExercise (0..1) + + condition: one-of + +type EuropeanExercise: + expirationDate AdjustableOrRelativeDate (1..*) + +type AdjustableOrRelativeDate: + adjustableDate AdjustableDate (0..1) + +type AdjustableDate: + adjustedDate string (0..1) + unadjustedDate string (0..1) + +type ForwardPayout: + settlementTerms SettlementTerms (1..1) + underlier Product (1..1) + +type ForeignExchange: + exchangedCurrency1 Cashflow (1..1) + exchangedCurrency2 Cashflow (1..1) + +type Cashflow extends PayoutBase: + payoutQuantity ResolvablePayoutQuantity (1..1) + +type ResolvablePayoutQuantity: + resolvedQuantity Quantity (1..1) + +type Quantity: + multiplier number (0..1) + location Address (0..1) + unitOfAmount UnitType (0..1) + +type Address: + street string (1..1) + +type UnitType: + currency string (0..1) + +type PayoutBase: + payerReceiver PayerReceiver (1..1) + +type PayerReceiver: + payer CounterpartyRoleEnum (1..1) + receiver CounterpartyRoleEnum (1..1) \ No newline at end of file diff --git a/resources/bkup/contractDSL.rosetta b/resources/bkup/contractDSL.rosetta new file mode 100644 index 0000000..6ce9261 --- /dev/null +++ b/resources/bkup/contractDSL.rosetta @@ -0,0 +1,416 @@ +namespace contractDSL : <"Generic product concepts: quantity, price, economic terms and payout, that are built using template features."> +version "${project.version}" + +import imports.types.* +import imports.enums.* + + +type Obs: + constant number (0..1) + exchangeRate ExchangeRate (0..1) + condition: one-of + +type ExchangeRate: + from UnitType (1..1) + to UnitType (1..1) + +func Konst: + inputs: + constant number (1..1) + output: + observable Obs (1..1) + assign-output observable -> constant: + constant + +func ExchangeRateFunc: + inputs: + from UnitType (1..1) + to UnitType (1..1) + output: + observable Obs (1..1) + assign-output observable -> exchangeRate -> from: + from + assign-output observable -> exchangeRate -> to: + to + +type Contract: + zero Contract_Zero (0..1) + expired Contract_Expired (0..1) + one Contract_One (0..1) + orContract Contract_Or (0..1) + both Contract_Both (0..1) + give Contract_Give (0..1) + thereafter Contract_Thereafter (0..1) + truncate Contract_Truncate (0..1) + scale Contract_Scale (0..1) + get Contract_Get (0..1) + anytime Contract_Anytime (0..1) + condition: one-of + +type Contract_Zero: + unit int (1..1) +type Contract_Expired: + unit int (1..1) +type Contract_One: + currency UnitType (1..1) +type Contract_Or: + left Contract (1..1) + right Contract (1..1) +type Contract_Both: + left Contract (1..1) + right Contract (1..1) +type Contract_Thereafter: + earlier Contract (1..1) + later Contract (1..1) +type Contract_Give: + contract Contract (1..1) +type Contract_Truncate: + expiryDate string (1..1) + contract Contract (1..1) +type Contract_Scale: + observable Obs (1..1) + contract Contract (1..1) +type Contract_Get: + contract Contract (1..1) +type Contract_Anytime: + contract Contract (1..1) + +func MkZero: + output: + contract Contract (1..1) + assign-output contract -> zero -> unit: + 1 // create the zero contract dummy value + +func MkExpired: + output: + contract Contract (1..1) + assign-output contract -> expired -> unit: + 1 // create the expired contract dummy value + +func MkOne: + inputs: + currency UnitType (1..1) + output: + contract Contract (1..1) + assign-output contract -> one -> currency: + currency + +func MkOr: + inputs: + left Contract (1..1) + right Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> orContract -> left: + left + assign-output contract -> orContract -> right: + right + +func MkBoth: + inputs: + left Contract (1..1) + right Contract (1..1) + output: + contract Contract (1..1) + assign-output contract -> both -> left: + left + assign-output contract -> both -> right: + 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 UnitType (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)) + +func AmericanOption: + inputs: + startDate string (1..1) + endDate string (1..1) + contract Contract (1..1) + output: + option Contract (1..1) + alias opt: MkAnytime(Perhaps(endDate,contract)) + assign-output option: + MkThereafter(MkGet (MkTruncate(startDate,opt)),opt) + +/* Swap the parties of a contract based on the party of a payout. Assuming we are Party1 */ +func PayoutParty1: + inputs: + payout PayoutBase (1..1) + contract Contract (1..1) + output: + contractOut Contract (1..1) + assign-output contractOut: + if (payout -> payerReceiver -> payer = CounterpartyRoleEnum -> Party1) + or (payout -> payerReceiver -> receiver = CounterpartyRoleEnum -> Party2) then + MkGive(contract) + else + contract + + +func ResolveQuantity: + inputs: + address Address (1..1) + tradeLot TradeLot (1..*) + output: + resolvedQuantity Quantity (1..1) + + alias resolvedValue: + tradeLot + map [item -> priceQuantity] + flatten + map [item -> quantity] + flatten + filter [item -> location = address] + only-element + + assign-output resolvedQuantity -> multiplier: + resolvedValue -> multiplier + + assign-output resolvedQuantity -> unitOfAmount: + resolvedValue -> unitOfAmount + +func CashflowPayoutToContract: + inputs: + cashflow Cashflow (1..1) + tradeLot TradeLot (1..*) + settlementTerms SettlementTerms (0..1) + output: + zcb Contract (1..1) + + alias quantity: + ResolveQuantity(cashflow -> payoutQuantity -> resolvedQuantity -> location only-element, tradeLot) + + alias fixingDate: + if settlementTerms -> cashSettlementTerms exists then + settlementTerms + -> cashSettlementTerms + only-element + -> valuationDate + -> fxFixingDate + -> fxFixingDate + -> adjustableDate + -> unadjustedDate + else + empty + + assign-output zcb: + PayoutParty1 + ( cashflow + , MkScale + ( Konst (quantity -> multiplier only-element) + , if fixingDate exists then + MkGet + ( MkTruncate + ( fixingDate only-element + , MkScale + ( ExchangeRateFunc(quantity -> unitOfAmount only-element, settlementTerms -> unitType) + , MkGet + ( MkTruncate + ( settlementTerms -> settlementDate -> valueDate + , MkOne (settlementTerms -> unitType) + ) + ) + ) + ) + ) + else + MkOne(quantity -> unitOfAmount only-element)) + ) + + +func ForeignExchangeToContract: + inputs: + foreignExchange ForeignExchange (1..1) + tradeLot TradeLot (1..*) + settlementTerms SettlementTerms (0..1) + output: + contract Contract (1..1) + + assign-output contract: + MkBoth + ( CashflowPayoutToContract(foreignExchange -> exchangedCurrency1, tradeLot, settlementTerms) + , CashflowPayoutToContract(foreignExchange -> exchangedCurrency2, tradeLot, settlementTerms) + ) + +func ForwardPayoutToContract: + inputs: + fx ForwardPayout (1..1) + tradeLot TradeLot (1..*) + output: + contract Contract (1..1) + assign-output contract: + MkGet + ( MkTruncate + ( fx -> settlementTerms -> settlementDate -> valueDate + , ForeignExchangeToContract + ( fx -> underlier -> foreignExchange + , tradeLot + , fx -> settlementTerms + ) + ) + ) + +func OptionPayoutToEuropean: + inputs: + optionPayout OptionPayout (1..1) + tradeLot TradeLot (1..*) + output: + contract Contract (1..1) + + alias europeanExerciseTerms: + optionPayout -> exerciseTerms -> optionStyle -> europeanExercise + alias adjustedExpirationDate: + europeanExerciseTerms -> expirationDate only-element -> adjustableDate -> adjustedDate + + assign-output contract: + EuropeanOption + ( adjustedExpirationDate only-element + // The cardinality on europeanExerciseTerms -> expirationDate is not (1..1)! + , ProductToContract(optionPayout -> underlier, tradeLot, optionPayout -> settlementTerms) + , optionPayout -> settlementTerms + ) + +func ContractualProductToContract: + inputs: + contractualProduct ContractualProduct (1..1) + tradeLot TradeLot (1..*) + settlementTerms SettlementTerms (0..1) + output: + contract Contract (1..1) + alias payout: contractualProduct -> economicTerms -> payout + assign-output contract: + if payout -> optionPayout exists then + payout + -> optionPayout + map [OptionPayoutToEuropean(item,tradeLot)] + reduce c1 c2 [MkBoth(c1,c2)] + + else if payout -> forwardPayout exists then + payout + -> forwardPayout + map [ForwardPayoutToContract(item,tradeLot)] + reduce c1 c2 [MkBoth(c1,c2)] + + else /* assume cashflow otherwise */ + payout + -> cashflow + map [CashflowPayoutToContract(item,tradeLot,settlementTerms)] + reduce c1 c2 [MkBoth(c1,c2)] + + +func ProductToContract: + inputs: + product Product (1..1) + tradeLot TradeLot (1..*) + settlementTerms SettlementTerms (0..1) + output: + contract Contract (1..1) + + assign-output contract: + if product -> contractualProduct exists then + ContractualProductToContract(product -> contractualProduct, tradeLot, settlementTerms) + else if product -> foreignExchange exists then + ForeignExchangeToContract(product -> foreignExchange, tradeLot, settlementTerms) + else + MkZero() + +func Main: + inputs: + //meta MetaData (1..1) + trade Trade (1..1) + output: + contract Contract (1..1) + + assign-output contract: + ProductToContract(trade -> tradableProduct -> product, trade -> tradableProduct -> tradeLot, empty) \ No newline at end of file diff --git a/resources/Rosetta/Contracts/imports-enums.rosetta b/resources/bkup/imports-enums.rosetta similarity index 100% rename from resources/Rosetta/Contracts/imports-enums.rosetta rename to resources/bkup/imports-enums.rosetta diff --git a/resources/Rosetta/Contracts/imports-types.rosetta b/resources/bkup/imports-types.rosetta similarity index 97% rename from resources/Rosetta/Contracts/imports-types.rosetta rename to resources/bkup/imports-types.rosetta index 46748a4..d66d934 100644 --- a/resources/Rosetta/Contracts/imports-types.rosetta +++ b/resources/bkup/imports-types.rosetta @@ -1,4 +1,4 @@ -namespace imports.types : <"Types used for the contract dsl"> +namespace imports : <"Types used for the contract dsl"> version "${version.ok}" import imports.enums.* diff --git a/src/Model/Type.hs b/src/Model/Type.hs index d475b4e..6570e9a 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -135,7 +135,10 @@ data Cardinality = Bounds (Integer, Integer) -- |The cardinality starting from one bound until infinity (ex. 5 - *) | OneBound Integer - deriving Show + +instance Show Cardinality where + show (Bounds (x, y)) = "(" ++ show x ++ ".." ++ show y ++ ")" + show (OneBound x) = "(" ++ show x ++ ".." ++ "*)" instance Eq Cardinality where (==) (Bounds (x1, x2)) (Bounds (y1, y2)) diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 414b2b2..656e196 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -66,13 +66,13 @@ listParser = return $ List (expressions ++ [lastExpr]) listOperations :: [String] -listOperations = ["map", "filter", "reduce"] +listOperations = ["map", "filter", "reduce", "contains", "disjoint"] -- |Parses a variable in Rosetta into an Expression variableParser :: Parser Expression variableParser = do - Variable <$> camelNameParser + Variable <$> nameParser enumValueParser :: Parser Expression enumValueParser = @@ -124,8 +124,9 @@ terminalParser = try booleanParser, try emptyParser, try decimalParser, - try variableParser, + try functionCallParser, try enumValueParser, + try variableParser, integerParser ] @@ -164,7 +165,7 @@ eqParser = -- |The list of equality statements in Rosetta eqFunctions :: [String] -eqFunctions = ["=", "<", "<=", ">", ">=", "<>"] +eqFunctions = ["=", "<=", "<>", "<", ">=", ">"] -- |Parses a sum statement in Rosetta into an Expression sumParser :: Parser Expression @@ -254,6 +255,14 @@ listOpParser = con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser exp <- nestedPostOp lst return $ reverseExpression $ Reduce (Text.unpack o) exp v1 v2 con + "contains" -> do + con <- expressionParser + exp <- nestedPostOp lst + return $ reverseExpression $ ListOp "contains" exp con + "disjoint" -> do + con <- expressionParser + exp <- nestedPostOp lst + return $ reverseExpression $ ListOp "disjoint" exp con _ -> do con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser exp <- nestedPostOp lst @@ -286,6 +295,14 @@ nestedListOp ex = con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser exp <- nestedPostOp ex return $ reverseExpression $ Reduce (Text.unpack o) exp v1 v2 con + "contains" -> do + con <- expressionParser + exp <- nestedPostOp ex + return $ reverseExpression $ ListOp "contains" exp con + "disjoint" -> do + con <- expressionParser + exp <- nestedPostOp ex + return $ reverseExpression $ ListOp "disjoint" exp con _ -> do con <- between (lexeme $ char '[') (lexeme $ char ']') expressionParser exp <- nestedPostOp ex diff --git a/src/Parser/Function.hs b/src/Parser/Function.hs index 5b6bfd9..8a1e158 100644 --- a/src/Parser/Function.hs +++ b/src/Parser/Function.hs @@ -38,9 +38,10 @@ aliasParser = assignmentParser :: Parser (Expression, Expression) assignmentParser = do - _ <- lexeme $ string "assign-output" + _ <- lexeme $ string "assign-output" <|> string "set" <|> string "add" out <- expressionParser _ <- lexeme $ char ':' + _ <- lexeme $ optional descriptionParser assignment <- expressionParser return (out, assignment) diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index 53c5b31..7551686 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -6,13 +6,13 @@ import Model.Type import Text.Megaparsec.Char import Text.Megaparsec import Data.Maybe -import Parser.General +import Parser.General import Parser.Expression (expressionParser) - + -- |Parses a type declaration statement in Rosetta into an Type typeParser :: Parser Type -typeParser = - do +typeParser = + do tName <- try typeNameParser tSuper <- superTypeParser _ <- lexeme $ char ':' @@ -33,29 +33,38 @@ superTypeParser = -- |Parses a declared type attribute in Rosetta into a TypeAttribute typeAttributeParser :: Parser TypeAttribute -typeAttributeParser = +typeAttributeParser = do + _ <- many $ lexeme metaParser aName <- try camelNameParser aType <- try nameParser card <- cardinalityParser desc <- optional descriptionParser + _ <- many $ lexeme metaParser return (MakeTypeAttribute aName (MakeType aType (BasicType "Object") Nothing [] []) card desc) +metaParser :: Parser String +metaParser = + do + _ <- lexeme $ char '[' + manyTill (letterChar <|> char ' ') (char ']') + -- |Parses the cardinality of a type attribute in Rosetta into a Cardinality cardinalityParser :: Parser Cardinality cardinalityParser = try parseBounded <|> try parseSemiBounded -- |Parser the condition of a type attribute in Rosetta into a Condition -conditionParser :: Parser Condition +conditionParser :: Parser Condition conditionParser = do _ <- lexeme $ string "condition" - description <- optional descriptionParser + _ <- optional $ lexeme pascalNameParser _ <- lexeme $ char ':' + description <- optional descriptionParser MakeCondition description <$> expressionParser -- |Parses a bounded cardinality statement in Rosetta into a Cardinality parseBounded :: Parser Cardinality -parseBounded = +parseBounded = do _ <- lexeme $ char '(' low <- lexeme $ many digitChar @@ -66,7 +75,7 @@ parseBounded = -- |Parses a one bounded cardinality statement in Rosetta into a Cardinality parseSemiBounded :: Parser Cardinality -parseSemiBounded = +parseSemiBounded = do _ <- lexeme $ char '(' low <- lexeme $ many digitChar @@ -75,7 +84,7 @@ parseSemiBounded = -- |Parses the name of a type in Rosetta into a String typeNameParser :: Parser String -typeNameParser = +typeNameParser = do _ <- lexeme $ string "type" pascalNameParser \ No newline at end of file diff --git a/src/PrettyPrinter/Header.hs b/src/PrettyPrinter/Header.hs index aa5df2d..d1d5a56 100644 --- a/src/PrettyPrinter/Header.hs +++ b/src/PrettyPrinter/Header.hs @@ -9,17 +9,17 @@ import Data.Char import Utils.Utils -- |Converts a Header into a haskell valid String -printHeader :: Header -> String -printHeader (MakeHeader name (Just description) _ imports) = - show $ vcat ["module" <+> pretty (removePeriods name) <+> "where", +printHeader :: FilePath -> Header -> String +printHeader path (MakeHeader name (Just description) _ imports) = + show $ vcat ["module" <+> pretty (removeChar path '-') <+> "where", enclose "{-" "-}" (pretty description), emptyDoc, "import" <+> "Data.List", "import" <+> "Data.Maybe", vcat (map printImport imports), emptyDoc] -printHeader (MakeHeader name Nothing _ imports) = - show $ vcat ["module" <+> pretty (removePeriods name) <+> "where", +printHeader path (MakeHeader name Nothing _ imports) = + show $ vcat ["module" <+> pretty (removeChar path '-') <+> "where", emptyDoc, "import" <+> "Data.List", "import" <+> "Data.Maybe", @@ -28,4 +28,4 @@ printHeader (MakeHeader name Nothing _ imports) = -- |Converts an import name into an import prettyprinter doc printImport :: String -> Doc a -printImport name = "import" <+> pretty (removePeriods name) \ No newline at end of file +printImport name = "import" <+> pretty (removeChar name '.') \ No newline at end of file diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index 303c496..469fd98 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -9,15 +9,19 @@ import Utils.Utils -- |A declared variable or function data Symbol = Var{ - varName :: String, + symbolName :: String, declaredType :: Type, cardinality :: Cardinality } | Func { - funcName :: String, + symbolName :: String, argsType :: [(Type, Cardinality)], returnType :: (Type, Cardinality) - } deriving (Show) + } + +instance Show Symbol where + show (Var n t c) = "Variable {name: " ++ show n ++ ", type: " ++ show t ++ ", card: " ++ show c ++ "}" + show (Func n i o) = "Function {name: " ++ show n ++ ", arguments: " ++ show [((typeName . fst) t, (snd t)) | t <- i] ++ ", return: (" ++ typeName (fst o) ++ ", " ++ show (snd o) ++ ")}" instance Eq Symbol where (==) (Var name1 _ _) (Var name2 _ _) @@ -96,7 +100,7 @@ addFunction (definedTypes, definedSymbols) (MakeFunction (MakeFunctionSignature case head $ checkAttributes definedTypes [out] of Left err -> Left [err] Right checkedOutput -> if null (lefts checkedInputs) - then if name `elem` map funcName definedSymbols + then if name `elem` map symbolName definedSymbols then Left [MultipleDeclarations name] else Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType checkedOutput, Model.Type.cardinality out) : definedSymbols else Left $ lefts checkedInputs @@ -261,10 +265,10 @@ checkList1 defT symbs (ex : exps) typ = -- |Checks whether the function that is called is already defined with the same argument types checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError ExplicitExpression ] -> Either TypeCheckError ExplicitExpression -checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: " ++ fun ++ " [" +checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: " ++ fun ++ " [" ++ show args ++ "]" ++ show [(typeName $ typeFromExpression x, toCardinality $ cardinalityCoercion $ returnCoercion x) | x <- rights args] ++ "]" checkFunctionCall ((Func n a r):symbolMap) name args - | not $ null $ lefts args = Left $ ErrorInsideFunction (name ++ ": " ++ show (lefts args)) + | not $ null $ lefts args = error $ show symbolMap ++ "\n" ++ show (lefts args)--Left $ ErrorInsideFunction (name ++ ": " ++ show (lefts args)) | name == n = if all isRight coerce then Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r))) else checkFunctionCall symbolMap name args | otherwise = checkFunctionCall symbolMap name args @@ -411,4 +415,4 @@ cardinalityIncluded (OneBound x) (Bounds (x2, y2)) = Left $ CardinalityMismatch cardinalityIncluded (Bounds (x1, x2)) (Bounds (y1, y2)) | x1 == y1 && x2 == y2 = Right $ MakeCardinalityIdCoercion (Bounds (x1, x2)) | x1 >= y1 && x2 <= y2 = Right $ MakeListCardinalityCoercion (Bounds (x1, x2)) (Bounds (y1, y2)) - | otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (Bounds (y1, y2)) + | otherwise = Left $ CardinalityMismatch (Bounds (x1, x2)) (Bounds (y1, y2)) \ No newline at end of file diff --git a/src/Utils/Utils.hs b/src/Utils/Utils.hs index ef00c51..706ee22 100644 --- a/src/Utils/Utils.hs +++ b/src/Utils/Utils.hs @@ -16,42 +16,27 @@ uncapitalize s = toLower (head s) : tail s -- |Convert a namespace to a filename namespaceToName :: String -> String namespaceToName [] = ".rosetta" -namespaceToName ".*" = ".rosetta" +namespaceToName ".*" = ".*" namespaceToName (c : cs) | c == '.' = '-' : namespaceToName cs | otherwise = c : namespaceToName cs --- |Returns the directory of a file from a path -fileDirectory :: String -> String -fileDirectory s = take (length s - length (fileName s)) s - --- |Returns the name of a file from a path -fileName :: String -> String -fileName path = reverse $ fileName1 $ reverse path - --- |Auxiliary function for the name of a file from a path -fileName1 :: String -> String -fileName1 [] = [] -fileName1 (c : cs) - | c == '/' = [] - | otherwise = c : fileName1 cs - -- |Create a new haskell filename based on the namespace haskellFileName :: String -> String -haskellFileName s = "resources/Generated/" ++ removePeriods s ++".hs" +haskellFileName s = "resources/Generated/" ++ removeChar s '-' ++".hs" -- |Function to remove all the periods from a name, and convert the name to CamelCase -removePeriods :: String -> String -removePeriods [] = [] -removePeriods ['*'] = [] -removePeriods (c:cs) = toUpper c : removePeriods1 cs +removeChar :: String -> Char -> String +removeChar [] _ = [] +removeChar ['*'] _ = [] +removeChar (c:cs) ch = toUpper c : removeChar1 cs ch -- |Auxiliary function for converting names -removePeriods1 :: String -> String -removePeriods1 [] = [] -removePeriods1 (c:cs) - | c == '.' = removePeriods cs - | otherwise = c : removePeriods1 cs +removeChar1 :: String -> Char -> String +removeChar1 [] ch = [] +removeChar1 (c:cs) ch + | c == ch = removeChar cs ch + | otherwise = c : removeChar1 cs ch -- |Extract the first elements from a list of tuples fstlst :: [(a, b)] -> [a] @@ -101,4 +86,10 @@ trd3 (_, _, x) = x replacePrefix :: Eq a => [a] -> [a] -> [a] -> [a] replacePrefix a b c = case stripPrefix a b of Nothing -> b - Just bs -> c ++ bs \ No newline at end of file + Just bs -> c ++ bs + +-- |Get the namespace name from the import +getNamespace :: String -> String +getNamespace [] = [] +getNamespace ".*" = [] +getNamespace (s : ss) = s : getNamespace ss \ No newline at end of file