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

changed compiler to whole folder

Browse Source
This commit is contained in:
Radu Macocian
2022-08-08 03:06:47 +02:00
parent 18b7e778a2
commit 24bfeea014
17 changed files with 711 additions and 84 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@@ -26,4 +26,5 @@ cabal.project.local~
.vscode/
/resources/Rosetta/Try/
/resources/fxspot.json
/resources/european contract.json
/resources/european contract.json
/resources/CDM/

6
RosettaParser.cabal
View File

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

115
app/Main.hs
View File

@@ -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)
generateFile :: ((FilePath, Header), [CheckedRosettaObject]) -> IO ()
generateFile ((path, header), objects) =
writeFile (haskellFileName $ dropExtension $ takeFileName path)
(printHeader (dropExtension $ takeFileName path) header ++ concatMap printRosettaObject objects)

2
package.yaml
View File

@@ -27,6 +27,8 @@ dependencies:
- prettyprinter
- parser-combinators
- text
- filepath
- directory
library:
source-dirs: src

3
resources/Rosetta/Contracts/contractDSL.rosetta
View File

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

6
resources/Rosetta/Contracts/imports-enum.rosetta Normal file
View File

@@ -0,0 +1,6 @@
namespace imports : <"Enums used for the contract dsl">
version "${version.ok}"
enum CounterpartyRoleEnum:
Party1
Party2

105
resources/Rosetta/Contracts/imports-type.rosetta Normal file
View File

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

416
resources/bkup/contractDSL.rosetta Normal file
View File

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

0
resources/Rosetta/Contracts/imports-enums.rosetta → resources/bkup/imports-enums.rosetta
View File

2
resources/Rosetta/Contracts/imports-types.rosetta → resources/bkup/imports-types.rosetta
View File

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

5
src/Model/Type.hs
View File

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

25
src/Parser/Expression.hs
View File

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

3
src/Parser/Function.hs
View File

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

29
src/Parser/Type.hs
View File

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

12
src/PrettyPrinter/Header.hs
View File

@@ -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)
printImport name = "import" <+> pretty (removeChar name '.')

18
src/Semantic/ExpressionChecker.hs
View File

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

45
src/Utils/Utils.hs
View File

@@ -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
Just bs -> c ++ bs
-- |Get the namespace name from the import
getNamespace :: String -> String
getNamespace [] = []
getNamespace ".*" = []
getNamespace (s : ss) = s : getNamespace ss