mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 13:00:08 +00:00
randomsave
This commit is contained in:
Macocian Adrian Radu
3
.gitignore
vendored
3
.gitignore
vendored
@@ -24,3 +24,6 @@ cabal.project.local~
|
||||
.idea/
|
||||
/resources/Generated/
|
||||
.vscode/
|
||||
/resources/Rosetta/Try/
|
||||
/resources/fxspot.json
|
||||
/resources/european contract.json
|
||||
@@ -29,8 +29,8 @@ import Parser.Expression (expressionParser)
|
||||
-- :l resources/Generated/ContractDSL.hs resources/Generated/ImportsTypes.hs resources/Generated/ImportsEnums.hs
|
||||
-- :set args resources/Rosetta/Contracts/contractDSL.rosetta
|
||||
|
||||
-- :set args resources/Rosetta/test-all.rosetta
|
||||
-- :l resources/Generated/testAll.hs resources/Generated/testPeriod.hs
|
||||
-- :l resources/Generated/ContractDSL.hs resources/Generated/ImportsTypes.hs
|
||||
-- :set args resources/Rosetta/Try/contractDSL.rosetta
|
||||
|
||||
-- |Reads a rosetta string from the first input argument and writes a haskell output to the file given as a second argument
|
||||
main :: IO ()
|
||||
|
||||
@@ -259,7 +259,7 @@ func ResolveQuantity:
|
||||
|
||||
assign-output resolvedQuantity -> unitOfAmount:
|
||||
resolvedValue -> unitOfAmount
|
||||
|
||||
/*
|
||||
func CashflowPayoutToContract:
|
||||
inputs:
|
||||
cashflow Cashflow (1..1)
|
||||
@@ -288,13 +288,13 @@ func CashflowPayoutToContract:
|
||||
PayoutParty1
|
||||
( cashflow
|
||||
, MkScale
|
||||
( Konst (quantity -> multiplier)
|
||||
( Konst (quantity -> multiplier only-element)
|
||||
, if fixingDate exists then
|
||||
MkGet
|
||||
( MkTruncate
|
||||
( fixingDate
|
||||
, MkScale
|
||||
( ExchangeRate(quantity -> unitOfAmount -> currency, settlementTerms -> settlementCurrency)
|
||||
( ExchangeRateFunc(quantity -> unitOfAmount, settlementTerms -> settlementCurrency)
|
||||
, MkGet
|
||||
( MkTruncate
|
||||
( settlementTerms -> settlementDate -> valueDate
|
||||
|
||||
@@ -63,7 +63,7 @@ type AdjustableOrRelativeDate:
|
||||
adjustableDate AdjustableDate (0..1)
|
||||
|
||||
type AdjustableDate:
|
||||
unadjastableDate string (0..1) //date
|
||||
unadjustedDate string (0..1) //date
|
||||
|
||||
type ForeignExchange:
|
||||
exchangedCurrency1 Cashflow (1..1)
|
||||
|
||||
@@ -64,6 +64,7 @@ data ExplicitExpression = ExplicitEmpty
|
||||
| ExplicitFunction {name :: String, args :: [(ExplicitExpression, Coercion)], returnCoercion :: Coercion}
|
||||
| ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
|
||||
| ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
|
||||
deriving (Eq)
|
||||
|
||||
changeCoercion :: ExplicitExpression -> Coercion -> ExplicitExpression
|
||||
changeCoercion ExplicitEmpty _ = ExplicitEmpty
|
||||
@@ -99,7 +100,7 @@ data TypeCoercion =
|
||||
MakeIdCoercion {toType :: Type}
|
||||
| MakeSuperCoercion {fromType :: Type, toType :: Type}
|
||||
| MakeTypeCoercion {fromType :: Type, toType :: Type, transformType :: String}
|
||||
deriving (Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data CardinalityCoercion =
|
||||
MakeCardinalityIdCoercion {toCardinality :: Cardinality}
|
||||
@@ -109,11 +110,10 @@ data CardinalityCoercion =
|
||||
| MakeMaybe2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
|
||||
| MakeObject2MaybeCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
|
||||
| MakeObject2ListCoercion {fromCardinality :: Cardinality, toCardinality :: Cardinality}
|
||||
deriving (Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |Used to handle polymorphism in Rosetta
|
||||
data Coercion = MakeCoercion {typeCoercion :: [TypeCoercion], cardinalityCoercion :: CardinalityCoercion} deriving(Show)
|
||||
|
||||
data Coercion = MakeCoercion {typeCoercion :: [TypeCoercion], cardinalityCoercion :: CardinalityCoercion} deriving(Eq, Show)
|
||||
|
||||
-- |The representation of an attribute of a data type
|
||||
data TypeAttribute = MakeTypeAttribute {
|
||||
@@ -191,4 +191,7 @@ createCoercion :: (Type, Cardinality) -> Coercion
|
||||
createCoercion (t, c) = MakeCoercion [MakeIdCoercion t] (MakeCardinalityIdCoercion c)
|
||||
|
||||
anyListCoercion :: Coercion
|
||||
anyListCoercion = MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (OneBound 0))
|
||||
anyListCoercion = MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (OneBound 0))
|
||||
|
||||
typeFromExpression :: ExplicitExpression -> Type
|
||||
typeFromExpression = coercionType . typeCoercion . returnCoercion
|
||||
@@ -200,7 +200,7 @@ powerParser =
|
||||
boolOpParser :: Parser Expression
|
||||
boolOpParser =
|
||||
do
|
||||
p <- pathExpressionParser
|
||||
p <- postfixParser
|
||||
op <- lexeme $ observing (string "or" <|> string "and")
|
||||
case op of
|
||||
Left _ -> return p
|
||||
@@ -210,12 +210,16 @@ boolOpParser =
|
||||
postfixParser :: Parser Expression
|
||||
postfixParser =
|
||||
do
|
||||
t <- listUnaryOpParser
|
||||
t <- pathExpressionParser
|
||||
op <- lexeme $ observing $ choice $ fmap (try . string . Text.pack) postfixFunctions
|
||||
case op of
|
||||
Left _ -> return t
|
||||
Right o -> return $ PostfixExp (Text.unpack o) t
|
||||
|
||||
-- |The list of existing postfix Rosetta functions
|
||||
postfixFunctions :: [String]
|
||||
postfixFunctions = ["exists", "is absent", "count", "only-element", "single exists", "multiple exists"]
|
||||
|
||||
|
||||
listUnaryOperations :: [String]
|
||||
listUnaryOperations = ["sum", "max", "flatten", "min", "join", "only-element", "count", "first", "last", "sort", "distinct"]
|
||||
@@ -277,16 +281,12 @@ nestedListOp ex =
|
||||
pathExpressionParser :: Parser Expression
|
||||
pathExpressionParser =
|
||||
do
|
||||
var <- postfixParser
|
||||
var <- listUnaryOpParser
|
||||
op <- lexeme $ observing $ string "->"
|
||||
case op of
|
||||
Left _ -> return var
|
||||
Right _ -> pathExpressionParser >>= \ex -> return $ reverseExpression $ PathExpression var ex
|
||||
|
||||
-- |The list of existing postfix Rosetta functions
|
||||
postfixFunctions :: [String]
|
||||
postfixFunctions = ["exists", "is absent", "count", "only-element", "single exists", "multiple exists"]
|
||||
|
||||
--------------------------------------------
|
||||
-- Auxiliary ------------------------------
|
||||
--------------------------------------------
|
||||
@@ -297,7 +297,7 @@ reverseExpression (InfixExp op t1 (InfixExp op2 t2 e))
|
||||
| precedence op == precedence op2 = InfixExp op2 (reverseExpression (InfixExp op t1 t2)) e
|
||||
| otherwise = InfixExp op t1 (InfixExp op2 t2 e)
|
||||
reverseExpression (PathExpression e1 (PathExpression e2 e3)) = PathExpression (reverseExpression (PathExpression e1 e2)) e3
|
||||
reverseExpression (PathExpression e1 (ListOp op ex2 cond)) = ListOp op cond (reverseExpression (PathExpression e1 ex2))
|
||||
reverseExpression (PathExpression e1 (ListOp op ex2 cond)) = ListOp op (reverseExpression (PathExpression e1 ex2)) cond
|
||||
reverseExpression (PathExpression e1 (ListUnaryOp op ex2)) = ListUnaryOp op (reverseExpression (PathExpression e1 ex2))
|
||||
reverseExpression (ListOp op1 (ListOp op2 ex2 con2) con1) = ListOp op2 (reverseExpression (ListOp op1 ex2 con1)) con2
|
||||
reverseExpression (ListOp op1 (ListUnaryOp op2 ex2) con1) = ListUnaryOp op2 (reverseExpression (ListOp op1 ex2 con1))
|
||||
|
||||
@@ -13,6 +13,7 @@ printExpression ExplicitEmpty = "[]"
|
||||
printExpression (ExplicitVariable name coer)
|
||||
| "item" `isPrefixOf` name = printCoercion coer $ pretty (replacePrefix "item" name "x")
|
||||
| otherwise = printCoercion coer $ pretty name
|
||||
printExpression (Value "empty" coer) = printCoercion coer "[]"
|
||||
printExpression (Value s coer) = printCoercion coer $ pretty s
|
||||
printExpression (ExplicitKeyword k) = pretty k
|
||||
printExpression (ExplicitEnumCall name val coer) = printCoercion coer $ pretty name <> pretty val
|
||||
@@ -24,11 +25,13 @@ printExpression (ExplicitListOp op lst cond coer) = pretty op <+> nest 4 (vsep [
|
||||
printExpression (ExplicitListUnaryOp "only-element" lst coer) = "head" <+> enclose "(" ")" (nest 4 (line <> printExpression lst))
|
||||
printExpression (ExplicitListUnaryOp "flatten" lst coer) = "concat" <+> enclose "(" ")" (nest 4 (line <> printExpression lst))
|
||||
printExpression (ExplicitListUnaryOp op lst coer) = pretty op <+> nest 4 (printExpression lst)
|
||||
printExpression (ExplicitPath ex1 (ExplicitVariable var ret) returnCoerce) =
|
||||
pretty (uncapitalize $ typeName $ coercionType $ typeCoercion $ returnCoercion ex1) <> pretty (capitalize var) <+>
|
||||
enclose "(" ")" (printExpression ex1)
|
||||
printExpression (ExplicitPath ex1 (ExplicitVariable var ret) returnCoerce)=
|
||||
pretty (uncapitalize $ typeName $ typeFromExpression ex1) <> pretty (capitalize var) <+> nest 4 (line <>
|
||||
enclose "(" ")" (printCoercion (returnCoercion ex1) (printExpression (ex1{returnCoercion = MakeCoercion [MakeIdCoercion (typeFromExpression ex1)] (MakeCardinalityIdCoercion (Bounds (1,1)))}))))
|
||||
printExpression ExplicitPath {} = error "This should never happen. Path Expression 2nd argument is not variable"
|
||||
printExpression (ExplicitFunction "exists" args returnCoerce) = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
printExpression (ExplicitFunction "exists" args returnCoerce)
|
||||
| toCardinality (cardinalityCoercion (snd (head args))) == Bounds (0, 1) = printCoercion returnCoerce "isJust" <+> enclose "(" ")" (printCoercion (snd $ head args) (printExpression (fst $ head args)))
|
||||
| otherwise = printCoercion returnCoerce "length" <+> enclose "(" ")" (printCoercion (snd $ head args) (printExpression (fst $ head args))) <+> ">=" <+> "1"
|
||||
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"
|
||||
@@ -45,38 +48,90 @@ printExpression (ExplicitFunction "and" args returnCoerce) = printCoercion (snd
|
||||
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) <> ")"
|
||||
else pretty (uncapitalize name) <+> printCoercion returnCoerce (hsep (map (enclose "(" ")") 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) =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+>
|
||||
"else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock))
|
||||
printExpression (ExplicitIfSimple cond thenBlock returnCoercion) =
|
||||
printIf
|
||||
(printCoercion (snd cond) (printExpression (fst cond)))
|
||||
(printCoercion (snd thenBlock) (printExpression (fst thenBlock)))
|
||||
(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 (ExplicitFunction op e rc, c) thenBlock elseBlock _)
|
||||
| op `elem` ["exists", "only exists"] = case isOneOf (fst (head e)) of
|
||||
Nothing -> printIf
|
||||
(printCoercion c (printExpression (ExplicitFunction op e rc)))
|
||||
(printCoercion (snd thenBlock) (printExpression (fst thenBlock)))
|
||||
(printCoercion (snd elseBlock) (printExpression (fst elseBlock)))
|
||||
Just ex -> "case" <+> printExpression (fst ex) <+> "of" <+> nest 4
|
||||
(line <> pretty (typeName (typeFromExpression (fst ex))) <> pretty (typeName (typeFromExpression (snd ex))) <+> "x" <+> "->"
|
||||
<+> printCoercion (snd thenBlock) (printExpression (replace (fst (head e)) (fst thenBlock) "x")) <> line <>
|
||||
getCases elseBlock)
|
||||
|
||||
| otherwise =
|
||||
printIf (printCoercion c (printExpression (ExplicitFunction op e rc)))
|
||||
(printCoercion (snd thenBlock) (printExpression (fst thenBlock)))
|
||||
(printCoercion (snd elseBlock) (printExpression (fst elseBlock)))
|
||||
|
||||
printExpression (ExplicitIfElse cond thenBlock elseBlock _) =
|
||||
printIf
|
||||
(printCoercion (snd cond) (printExpression (fst cond)))
|
||||
(printCoercion (snd thenBlock) (printExpression (fst thenBlock)))
|
||||
(printCoercion (snd elseBlock) (printExpression (fst elseBlock)))
|
||||
|
||||
printIf :: Doc a -> Doc a -> Doc a -> Doc a
|
||||
printIf cond thenBlock elseBlock = "if" <+> cond <+> nest 4 ( line <>
|
||||
"then" <+> thenBlock <+> line <>
|
||||
"else" <+> elseBlock)
|
||||
|
||||
-- |Converts a coercion into a haskell string
|
||||
printCoercion :: Coercion -> Doc a -> Doc a
|
||||
printCoercion (MakeCoercion [] crd) d = printCardinalityCoercion crd d
|
||||
printCoercion (MakeCoercion (t: ts) crd) d = printTypeCoercion t <> printCoercion (MakeCoercion ts crd) d
|
||||
printCoercion (MakeCoercion (t: ts) crd) d = printCoercion (MakeCoercion ts crd) d <> printTypeCoercion t
|
||||
|
||||
printCardinalityCoercion :: CardinalityCoercion -> Doc a -> Doc a
|
||||
printCardinalityCoercion (MakeCardinalityIdCoercion _) d = d
|
||||
printCardinalityCoercion (MakeListCardinalityCoercion _ _) d = d
|
||||
printCardinalityCoercion (MakeNothing2MaybeCoercion _ _) d = "Nothing"
|
||||
printCardinalityCoercion (MakeNothing2ListCoercion _ _) d = "[]"
|
||||
printCardinalityCoercion (MakeMaybe2ListCoercion _ _) d = "maybeToList" <+> d
|
||||
printCardinalityCoercion (MakeObject2MaybeCoercion _ _) d = "Just" <+> d
|
||||
printCardinalityCoercion (MakeMaybe2ListCoercion _ _) d = "maybeToList" <+> enclose "(" ")" d
|
||||
printCardinalityCoercion (MakeObject2MaybeCoercion _ _) d = "fromJust" <+> enclose "(" ")" d
|
||||
printCardinalityCoercion (MakeObject2ListCoercion _ _) d = "[" <> d <> "]"
|
||||
|
||||
printTypeCoercion :: TypeCoercion -> Doc a
|
||||
printTypeCoercion (MakeIdCoercion _) = emptyDoc
|
||||
printTypeCoercion (MakeSuperCoercion _ _) = "super" <+> emptyDoc
|
||||
printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t <+> emptyDoc
|
||||
printTypeCoercion (MakeSuperCoercion _ _) = "Super"
|
||||
printTypeCoercion (MakeTypeCoercion _ _ t) = pretty t
|
||||
|
||||
-- |Converts a list of type attributes to a Doc with a list of variable names
|
||||
printVariableNames :: [TypeAttribute] -> Doc a
|
||||
printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars)
|
||||
printVariableNames vars = foldl (<+>) emptyDoc (map (pretty . attributeName) vars)
|
||||
|
||||
isOneOf :: ExplicitExpression -> Maybe (ExplicitExpression, ExplicitExpression)
|
||||
isOneOf (ExplicitPath e1 e2 c)
|
||||
| not (null (conditions (typeFromExpression e1))) &&
|
||||
MakeCondition Nothing (Keyword "one-of") `elem` conditions (typeFromExpression e1) = Just (e1, e2)
|
||||
| otherwise = Nothing
|
||||
isOneOf _ = Nothing
|
||||
|
||||
getCases :: (ExplicitExpression, Coercion) -> Doc a
|
||||
getCases (ExplicitIfElse (ExplicitFunction op e rc, c) thn els coer, retCoer)
|
||||
| op `elem` ["exists", "only exists"] = case isOneOf (fst (head e)) of
|
||||
Nothing -> "_" <+> "->" <+> printExpression (ExplicitIfElse (ExplicitFunction op e rc, c) thn els coer)
|
||||
Just ex -> pretty (typeName (typeFromExpression (fst ex))) <> pretty (typeName (typeFromExpression (snd ex))) <+> "x" <+> "->"
|
||||
<+> printCoercion (snd thn) (printExpression (replace (fst (head e)) (fst thn) "x")) <> line <>
|
||||
getCases els
|
||||
getCases (e, c) = "_" <+> "->" <+> printCoercion c (printExpression e)
|
||||
|
||||
replace :: ExplicitExpression -> ExplicitExpression -> String -> ExplicitExpression
|
||||
replace e1 (ExplicitPath pe1 pe2 c) x
|
||||
| e1 == ExplicitPath pe1 pe2 c = ExplicitVariable x c
|
||||
| otherwise = ExplicitPath (replace e1 pe1 x) pe2 c
|
||||
replace e1 (ExplicitListUnaryOp op e2 c) x = ExplicitListUnaryOp op (replace e1 e2 x) c
|
||||
replace e1 (ExplicitListOp op e2 cond c) x = ExplicitListOp op (replace e1 e2 x) (replace e1 cond x) c
|
||||
replace e1 (ExplicitParens e2 c) x = ExplicitParens (replace e1 e2 x) c
|
||||
replace e1 (ExplicitFunction op e2 c) x = ExplicitFunction op [(replace e1 (fst e) x, snd e) | e <- e2] c
|
||||
replace e1 (ExplicitIfSimple cond e2 c) x = ExplicitIfSimple (replace e1 (fst cond) x, snd cond) (replace e1 (fst e2) x, snd e2) c
|
||||
replace e1 (ExplicitIfElse cond thn els c) x = ExplicitIfElse (replace e1 (fst cond) x, snd cond) (replace e1 (fst thn) x, snd thn) (replace e1 (fst els) x, snd els) c
|
||||
replace _ e _ = e
|
||||
@@ -40,7 +40,7 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod
|
||||
|
||||
-- |Converts the body of a Function into a haskell valid Doc
|
||||
printFunctionBody :: ExplicitFunction -> Doc a
|
||||
printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) alias ex) =
|
||||
printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) alias ex) =
|
||||
pretty name <+> printVariableNames inp <+> "=" <+>
|
||||
nest 4 (vsep (map printAlias alias ++
|
||||
[printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex])]))
|
||||
|
||||
@@ -14,11 +14,15 @@ printHeader (MakeHeader name (Just description) _ imports) =
|
||||
show $ vcat ["module" <+> pretty (removePeriods name) <+> "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",
|
||||
emptyDoc,
|
||||
"import" <+> "Data.List",
|
||||
"import" <+> "Data.Maybe",
|
||||
vcat (map printImport imports),
|
||||
emptyDoc]
|
||||
|
||||
|
||||
@@ -33,6 +33,7 @@ printAttributes :: String -> [Condition] -> [TypeAttribute] -> Doc a
|
||||
printAttributes objName conditions ats
|
||||
| MakeCondition Nothing (Keyword "one-of") `elem` conditions = vcat [nest 4 $ vcat $
|
||||
zipWith (<>) ("" : repeat "| ") (map (printSumType objName) (increaseBound ats)) ++ map printCondition conditions, " deriving (Eq)"]
|
||||
| null ats = emptyDoc
|
||||
| length ats < 2 = vcat [nest 4 $ vcat $
|
||||
zipWith (<>) ("" : repeat "| ") (map (printSumType objName) ats) ++ map printCondition conditions, " deriving (Eq)", printDefault objName (objName ++ capitalize (attributeName (head ats))) ats]
|
||||
| otherwise = vcat [nest 4 $ vcat ("Make" <> pretty objName <+> "{" :
|
||||
|
||||
@@ -34,7 +34,7 @@ defaultMap :: [Symbol]
|
||||
defaultMap = [
|
||||
Func "or" [(BasicType "Boolean", Bounds (1, 1)), (BasicType "Boolean", Bounds (1, 1))] (BasicType "Boolean", Bounds (1, 1)),
|
||||
Func "and" [(BasicType "Boolean", Bounds (1, 1)), (BasicType "Boolean", Bounds (1, 1))] (BasicType "Boolean", Bounds (1, 1)),
|
||||
Func "exists" [(BasicType "Any", Bounds (0, 1))] (BasicType "Boolean", Bounds(1, 1)),
|
||||
Func "exists" [(BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)),
|
||||
Func "is absent" [(BasicType "Any", Bounds (0, 1))] (BasicType "Boolean", Bounds (1, 1)),
|
||||
Func "single exists" [(BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)),
|
||||
Func "multiple exists" [(BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)),
|
||||
@@ -80,8 +80,15 @@ listFunctionTypes :: Coercion -> Coercion -> [(String, Coercion, Coercion)]
|
||||
listFunctionTypes inp ex = [
|
||||
-- The function given to a filter must be boolean and it can return anything
|
||||
("filter", MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (OneBound 0)), inp),
|
||||
("map", MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (OneBound 0)), ex)
|
||||
]
|
||||
("map", MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (OneBound 0)), MakeCoercion (typeCoercion ex) (cardinalityCoercion inp)),
|
||||
("reduce", MakeCoercion [MakeIdCoercion (BasicType "Any")] (MakeCardinalityIdCoercion (Bounds (1, 1))), ex)
|
||||
]
|
||||
|
||||
listUnaryFunctionTypes :: Coercion -> [(String, Coercion)]
|
||||
listUnaryFunctionTypes inp = [
|
||||
("only-element", MakeCoercion (typeCoercion inp) (MakeCardinalityIdCoercion (Bounds (1, 1)))),
|
||||
("flatten", inp)
|
||||
]
|
||||
|
||||
-- |Checks whether a function is valid (inputs, outputs are of valid type and all variables are defined) and adds it to the symbol table
|
||||
addFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] [Symbol]
|
||||
@@ -104,7 +111,7 @@ addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskel
|
||||
-- |Checks the type of a given expression
|
||||
checkExpression :: [Type] -> [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression
|
||||
--checkExpression sym _ = error $ show sym
|
||||
checkExpression defT symbolMap (Variable var) = findVarType var symbolMap
|
||||
checkExpression _ symbolMap (Variable var) = findVarType var symbolMap
|
||||
checkExpression _ _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Integer")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
|
||||
checkExpression _ _ (Real val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Double")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
|
||||
checkExpression _ _ (Boolean val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
|
||||
@@ -116,16 +123,16 @@ checkExpression defT symbolMap (Enum enum val) = case getType enum defT of
|
||||
else Left $ UndefinedVariable val
|
||||
checkExpression defT symbolMap (ListOp op lst cond) =
|
||||
case checkExpression defT symbolMap lst of
|
||||
Left err -> Left err
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right checkedLst -> if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
|
||||
then Left $ ListOperationNotOnList $ show lst
|
||||
then Left $ ListOperationNotOnList $ show op ++ ": " ++ show lst
|
||||
else let it = getNextItem symbolMap in
|
||||
case checkExpression defT
|
||||
(addVariables symbolMap [MakeTypeAttribute it (coercionType $ typeCoercion $ returnCoercion checkedLst) (toCardinality $ cardinalityCoercion $ returnCoercion checkedLst) Nothing])
|
||||
(addVariables symbolMap [MakeTypeAttribute it (typeFromExpression checkedLst) (Bounds (1,1)) Nothing])
|
||||
(replaceVar cond it) of
|
||||
Left err -> Left err
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right condType -> case returnCoercion condType `coercionIncluded` head [snd3 x | x <- listOps, fst3 x == op] of
|
||||
Left err -> Left err
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right checkedCond -> Right $ ExplicitListOp op checkedLst (changeCoercion condType checkedCond) (head [trd3 x | x <- listOps, fst3 x == op])
|
||||
where
|
||||
listOps = listFunctionTypes (returnCoercion checkedLst) (returnCoercion condType)
|
||||
@@ -133,17 +140,22 @@ checkExpression defT symbolMap (ListUnaryOp op lst) =
|
||||
case checkExpression defT symbolMap lst of
|
||||
Left err -> Left $ ErrorInsideFunction $ op ++ ": " ++ show err
|
||||
Right checkedLst -> if toCardinality (cardinalityCoercion (returnCoercion checkedLst)) == Bounds(1, 1)
|
||||
then Left $ ListOperationNotOnList $ show lst
|
||||
else Right $ ExplicitListUnaryOp op checkedLst (returnCoercion checkedLst)
|
||||
then Left $ ListOperationNotOnList $ show op ++ ": " ++ show lst
|
||||
else if op `elem` map fst (listUnaryFunctionTypes (returnCoercion checkedLst))
|
||||
then Right $ ExplicitListUnaryOp op checkedLst (head [snd x | x <- listUnaryFunctionTypes (returnCoercion checkedLst), fst x == op])
|
||||
else Left $ UndefinedFunction op
|
||||
checkExpression _ _ (Keyword k) = Right $ ExplicitKeyword k
|
||||
checkExpression defT symbolMap (PathExpression ex1 (Variable b)) =
|
||||
checkExpression defT symbolMap (PathExpression ex1 (Variable b)) =
|
||||
case checkExpression defT symbolMap ex1 of
|
||||
Left err -> Left err
|
||||
Right exp1 -> case findAttributeTypeRec defT b type1 of
|
||||
Left err -> Left $ UndefinedVariable $ show (typeName type1) ++ " -> " ++ b
|
||||
Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2)
|
||||
Right exp2 -> case Bounds(1, 1) `cardinalityIncluded` crd1 of
|
||||
Left err -> Left $ PathExpressionOnList (show ex1)
|
||||
Right c -> Right $ ExplicitPath (changeCoercion exp1 ((returnCoercion exp1){cardinalityCoercion = c})) exp2 (returnCoercion exp2)
|
||||
where
|
||||
type1 = coercionType $ typeCoercion $ returnCoercion exp1
|
||||
type1 = typeFromExpression exp1
|
||||
crd1 = toCardinality $ cardinalityCoercion $ returnCoercion exp1
|
||||
-- |Getting here means that an expression is used inside a path expression and this is not supported
|
||||
checkExpression _ _ (PathExpression _ ex) = Left $ UnsupportedExpressionInPathExpression $ show ex
|
||||
--checkExpression symbolMap (PathExpression ex1 (PathExpression ))
|
||||
@@ -161,17 +173,17 @@ checkExpression defT symbolMap (IfSimple cond ex) =
|
||||
case checkExpression defT symbolMap cond of
|
||||
Left err -> Left $ IfConditionNotBoolean $ show err
|
||||
Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of
|
||||
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType)
|
||||
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (typeFromExpression condType)
|
||||
Right condCoerce ->
|
||||
case checkExpression defT symbolMap ex of
|
||||
Left err -> Left err
|
||||
Right thenExp ->
|
||||
Right $ ExplicitIfSimple (condType, condCoerce)
|
||||
(thenExp, thenCoercion)
|
||||
(MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
|
||||
(MakeCoercion [MakeIdCoercion $ typeFromExpression thenExp]
|
||||
(MakeCardinalityIdCoercion $ smallestBound (Bounds (0, 0)) (toCardinality $ cardinalityCoercion $ returnCoercion thenExp)))
|
||||
where
|
||||
thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
|
||||
thenCoercion = MakeCoercion [MakeIdCoercion $ typeFromExpression thenExp]
|
||||
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp)
|
||||
|
||||
-- |Checks if the condition of the if statement is of type boolean, and then checks that both the then and else statements have the same type
|
||||
@@ -179,7 +191,7 @@ checkExpression defT symbolMap (IfElse cond ex1 ex2) =
|
||||
case checkExpression defT symbolMap cond of
|
||||
Left err -> Left $ IfConditionNotBoolean $ show err
|
||||
Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of
|
||||
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (coercionType $ typeCoercion $ returnCoercion condType)
|
||||
Left err -> Left $ IfConditionNotBoolean $ show cond ++ " :: " ++ show (typeFromExpression condType)
|
||||
Right condCoerce ->
|
||||
case checkExpression defT symbolMap ex1 of
|
||||
Left err -> Left $ ErrorInsideFunction $ show err
|
||||
@@ -187,9 +199,9 @@ checkExpression defT symbolMap (IfElse cond ex1 ex2) =
|
||||
Left err -> Left $ ErrorInsideFunction $ show err
|
||||
Right elseExp ->
|
||||
Right $ ExplicitIfElse (condType, condCoerce)
|
||||
(thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp]
|
||||
(thenExp, MakeCoercion [MakeIdCoercion $ typeFromExpression thenExp]
|
||||
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp))
|
||||
(elseExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion elseExp]
|
||||
(elseExp, MakeCoercion [MakeIdCoercion $ typeFromExpression elseExp]
|
||||
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion elseExp)) (returnCoercion thenExp)
|
||||
--(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type)
|
||||
|
||||
@@ -201,7 +213,7 @@ checkList defT symbs (ex : exps) =
|
||||
case checkExpression defT symbs ex of
|
||||
Left err -> Left err
|
||||
Right x ->
|
||||
case checkList1 defT symbs exps (coercionType $ typeCoercion $ returnCoercion x, toCardinality $ cardinalityCoercion $ returnCoercion x) of
|
||||
case checkList1 defT symbs exps (typeFromExpression x, toCardinality $ cardinalityCoercion $ returnCoercion x) of
|
||||
Left err -> Left err
|
||||
Right exp -> Right $ ExplicitList exp
|
||||
|
||||
@@ -219,12 +231,13 @@ checkList1 defT symbs (ex : exps) typ =
|
||||
Left err -> Left err
|
||||
Right explicitEx -> Right [ExplicitList explicitEx]
|
||||
where
|
||||
exTyp = coercionType $ typeCoercion $ returnCoercion exCo
|
||||
exTyp = typeFromExpression exCo
|
||||
exCard = toCardinality $ cardinalityCoercion $ returnCoercion exCo
|
||||
|
||||
-- |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 ++ " [" ++ show (rights args) ++ "]"
|
||||
checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: " ++ fun ++ " ["
|
||||
++ 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))
|
||||
| name == n = if all isRight coerce then Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r)))
|
||||
@@ -282,8 +295,8 @@ findVarType x (_:symbols) = findVarType x symbols
|
||||
-- |Look for a type attribute in a given type and its super types
|
||||
findAttributeTypeRec :: [Type] -> String -> Type -> Either TypeCheckError ExplicitExpression
|
||||
findAttributeTypeRec _ var (BasicType _) = Left $ UndefinedVariable var
|
||||
findAttributeTypeRec sTable var t = case findAttributeType var (getTypeAttributes sTable t) of
|
||||
Left err -> case findAttributeTypeRec sTable var (superType t) of
|
||||
findAttributeTypeRec defT var t = case findAttributeType var (getTypeAttributes defT t) of
|
||||
Left err -> case findAttributeTypeRec defT var (superType t) of
|
||||
Left err -> Left err
|
||||
Right (ExplicitVariable n (MakeCoercion tc cc)) -> Right $
|
||||
ExplicitVariable n
|
||||
@@ -316,6 +329,7 @@ replaceVar e _ = e
|
||||
|
||||
-- |Checks whether the first argument is a subtype of the second argument
|
||||
isSubType :: Type -> Type -> Either TypeCheckError [TypeCoercion]
|
||||
isSubType (BasicType "Empty") _ = Right [MakeIdCoercion (BasicType "Empty")]
|
||||
isSubType (BasicType "Integer") (BasicType "Double") = Right [MakeTypeCoercion (BasicType "Integer") (BasicType "Double") "fromInteger"]
|
||||
isSubType t (BasicType "Any") = Right [MakeIdCoercion t]
|
||||
isSubType (BasicType x) y
|
||||
@@ -335,14 +349,16 @@ getNextItem symbs
|
||||
-- |Finds the type attributes from a type in the symbol table
|
||||
getTypeAttributes :: [Type] -> Type -> [TypeAttribute]
|
||||
getTypeAttributes [] t = []
|
||||
getTypeAttributes (defT : ts) t
|
||||
| typeName defT == typeName t =
|
||||
getTypeAttributes defT t
|
||||
| t `elem` defT = let typ = head [x | x <- defT, x == t] in
|
||||
[MakeTypeAttribute {attributeName = attributeName attr,
|
||||
attributeType = toHaskell (attributeType attr),
|
||||
Model.Type.cardinality = if MakeCondition Nothing (Keyword "one-of") `elem` conditions defT then Bounds (1,1) else Model.Type.cardinality attr,
|
||||
attributeType = case getType (typeName $ attributeType attr) defT of
|
||||
Left _ -> toHaskell (attributeType attr)
|
||||
Right atTyp -> atTyp,
|
||||
Model.Type.cardinality = Model.Type.cardinality attr,
|
||||
attributeDescription = attributeDescription attr}
|
||||
| attr <- typeAttributes defT]
|
||||
| otherwise = getTypeAttributes ts t
|
||||
| attr <- typeAttributes typ]
|
||||
| otherwise = []
|
||||
|
||||
-- |Checks whether the first cardinality is included into the second one
|
||||
cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError CardinalityCoercion
|
||||
@@ -354,18 +370,20 @@ cardinalityIncluded (Bounds (0, 0)) (OneBound 0) = Right $ MakeNothing2ListCoerc
|
||||
-- |Transform maybe into list
|
||||
cardinalityIncluded (Bounds (0, 1)) (OneBound 0) = Right $ MakeMaybe2ListCoercion (Bounds (0, 1)) (OneBound 0)
|
||||
-- |Transform object into maybe
|
||||
cardinalityIncluded (Bounds (1, 1)) (Bounds (0, 1)) = Right $ MakeObject2MaybeCoercion (Bounds (0, 1)) (Bounds (0, 1))
|
||||
cardinalityIncluded (Bounds (1, 1)) (Bounds (0, 1)) = Right $ MakeObject2MaybeCoercion (Bounds (1, 1)) (Bounds (0, 1))
|
||||
-- |Transform object into list
|
||||
cardinalityIncluded (Bounds (1, 1)) (OneBound 1) = Right $ MakeObject2ListCoercion (Bounds (0, 1)) (OneBound 1)
|
||||
cardinalityIncluded (Bounds (1, 1)) (OneBound 0) = Right $ MakeObject2ListCoercion (Bounds (0, 1)) (OneBound 1)
|
||||
cardinalityIncluded (Bounds (1, 1)) (OneBound 1) = Right $ MakeObject2ListCoercion (Bounds (1, 1)) (OneBound 1)
|
||||
cardinalityIncluded (Bounds (1, 1)) (OneBound 0) = Right $ MakeObject2ListCoercion (Bounds (1, 1)) (OneBound 1)
|
||||
-- |General
|
||||
cardinalityIncluded (OneBound x) (OneBound y)
|
||||
| x >= y = Right $ MakeListCardinalityCoercion (OneBound x) (OneBound y)
|
||||
| x == y = Right $ MakeCardinalityIdCoercion (OneBound x)
|
||||
| x > y = Right $ MakeListCardinalityCoercion (OneBound x) (OneBound y)
|
||||
| otherwise = Left $ CardinalityMismatch (OneBound x) (OneBound y)
|
||||
cardinalityIncluded (Bounds (x1, y1)) (OneBound y)
|
||||
| x1 >= y = Right $ MakeListCardinalityCoercion (Bounds (x1, y1)) (OneBound y)
|
||||
| otherwise = Left $ CardinalityMismatch (Bounds (x1, y1)) (OneBound y)
|
||||
cardinalityIncluded (OneBound x) (Bounds (x2, y2)) = Left $ CardinalityMismatch (OneBound x) (Bounds (x2, y2))
|
||||
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))
|
||||
|
||||
@@ -42,10 +42,10 @@ checkAssignment defT symbs ((assign, ex): assigns) =
|
||||
|
||||
addAliases :: [Type] -> [Symbol] -> [(String, Expression)] -> Either TypeCheckError ([Symbol], [(String, ExplicitExpression)])
|
||||
addAliases definedTypes symbolMap [] = Right (symbolMap, [])
|
||||
addAliases definedTypes symbolMap (alias : aliases) =
|
||||
addAliases definedTypes symbolMap (alias : aliases) =
|
||||
case checkExpression definedTypes symbolMap (snd alias) of
|
||||
Left err -> Left err
|
||||
Right ex -> case add of
|
||||
Left err -> Left err
|
||||
Right added -> Right (fst added, (fst alias, ex) : snd added)
|
||||
where add = addAliases definedTypes (addVariables symbolMap [MakeTypeAttribute (fst alias) (coercionType $ typeCoercion $ returnCoercion ex) (toCardinality $ cardinalityCoercion $ returnCoercion ex) Nothing]) aliases
|
||||
where add = addAliases definedTypes (addVariables symbolMap [MakeTypeAttribute (fst alias) (typeFromExpression ex) (toCardinality $ cardinalityCoercion $ returnCoercion ex) Nothing]) aliases
|
||||
@@ -18,6 +18,7 @@ data TypeCheckError =
|
||||
| TypeNameReserved String
|
||||
| UnsupportedExpressionInPathExpression String
|
||||
| ListOperationNotOnList String
|
||||
| PathExpressionOnList String
|
||||
deriving (Show)
|
||||
|
||||
-- |Checks whether a data type is valid
|
||||
|
||||
Reference in New Issue
Block a user