mirror of
https://github.com/macocianradu/RosettaHaskellCompiler.git
synced 2026-03-18 13:00:08 +00:00
kind of working,
still needs testing. Added output return coercion in expression Fixed formatting bugs
This commit is contained in:
@@ -11,6 +11,14 @@ type Obs:
|
||||
exchangeRate ExchangeRate (0..1)
|
||||
condition: one-of
|
||||
|
||||
func Konst:
|
||||
inputs:
|
||||
constant number (1..1)
|
||||
output:
|
||||
observable Obs (1..1)
|
||||
assign-output observable -> constant:
|
||||
constant
|
||||
|
||||
func ExchangeRateFunc:
|
||||
inputs:
|
||||
from int (1..1)
|
||||
@@ -78,7 +86,7 @@ func MkExpired:
|
||||
|
||||
func MkOne:
|
||||
inputs:
|
||||
currency UnitType (1..1)
|
||||
currency int (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> one -> currency:
|
||||
@@ -104,4 +112,99 @@ func MkBoth:
|
||||
assign-output contract -> both -> left:
|
||||
left
|
||||
assign-output contract -> both -> right:
|
||||
right
|
||||
right
|
||||
|
||||
func MkThereafter:
|
||||
inputs:
|
||||
earlier Contract (1..1)
|
||||
later Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> thereafter -> earlier:
|
||||
earlier
|
||||
assign-output contract -> thereafter -> later:
|
||||
later
|
||||
|
||||
func MkGive:
|
||||
inputs:
|
||||
subContract Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> give -> contract:
|
||||
subContract
|
||||
|
||||
func MkTruncate:
|
||||
inputs:
|
||||
truncateTo string (1..1)
|
||||
subContract Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> truncate -> contract:
|
||||
subContract
|
||||
assign-output contract -> truncate -> expiryDate:
|
||||
truncateTo
|
||||
|
||||
func MkScale:
|
||||
inputs:
|
||||
observable Obs (1..1)
|
||||
subContract Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> scale -> contract:
|
||||
subContract
|
||||
assign-output contract -> scale -> observable:
|
||||
observable
|
||||
|
||||
func MkGet:
|
||||
inputs:
|
||||
subContract Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> get -> contract:
|
||||
subContract
|
||||
|
||||
func MkAnytime:
|
||||
inputs:
|
||||
subContract Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract -> anytime -> contract:
|
||||
subContract
|
||||
|
||||
func MkAnd:
|
||||
inputs:
|
||||
left Contract (1..1)
|
||||
right Contract (1..1)
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract:
|
||||
MkThereafter(MkBoth(left,right),MkOr(left,right))
|
||||
|
||||
func ZeroCouponBond:
|
||||
inputs:
|
||||
maturesOn string (1..1) <"Date the bond matures on">
|
||||
amount number (1..1) <"Amount of the bond is worth">
|
||||
currency int (1..1) <"Unit the bond is denoted in">
|
||||
output:
|
||||
contract Contract (1..1)
|
||||
assign-output contract:
|
||||
MkGet (MkTruncate(maturesOn, MkScale(Konst(amount),MkOne(currency))))
|
||||
|
||||
func Perhaps:
|
||||
inputs:
|
||||
endDate string (1..1)
|
||||
contract Contract (1..1)
|
||||
output:
|
||||
perhaps Contract (1..1)
|
||||
assign-output perhaps:
|
||||
MkTruncate(endDate,MkOr(contract,MkZero()))
|
||||
|
||||
func EuropeanOption:
|
||||
inputs:
|
||||
endDate string (1..1)
|
||||
contract Contract (1..1)
|
||||
output:
|
||||
option Contract (1..1)
|
||||
|
||||
assign-output option:
|
||||
MkGet(Perhaps(endDate,contract))
|
||||
@@ -1,13 +1,21 @@
|
||||
namespace test.period : <"Something">
|
||||
version "${version.ok}"
|
||||
|
||||
enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week.">
|
||||
D displayName "day" <"Day">
|
||||
M displayName "month" <"Month">
|
||||
Y displayName "year" <"Year">
|
||||
|
||||
type Period: <"description">
|
||||
periodMultiplier int (1..1) <"A time period multiplier, e.g. 1, 2 or 3 etc. A negative value can be used when specifying an offset relative to another date, e.g. -2 days.">
|
||||
testMany boolean (0..*) <"Test many">
|
||||
testSome boolean (1..*) <"Test some">
|
||||
testMaybeOne int (0..1) <"Test zero or one">
|
||||
type ExchangeRate:
|
||||
from int (1..1)
|
||||
to int (1..1)
|
||||
|
||||
|
||||
type Obs:
|
||||
constant number (0..1)
|
||||
exchangeRate ExchangeRate (0..1)
|
||||
condition: one-of
|
||||
|
||||
func Konst:
|
||||
inputs:
|
||||
constant number (1..1)
|
||||
output:
|
||||
observable Obs (1..1)
|
||||
assign-output observable -> constant:
|
||||
constant
|
||||
@@ -58,6 +58,18 @@ data ExplicitExpression = ExplicitEmpty
|
||||
| ExplicitIfSimple {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
|
||||
| ExplicitIfElse {cond :: (ExplicitExpression, Coercion), block1 :: (ExplicitExpression, Coercion), block2 :: (ExplicitExpression, Coercion), returnCoercion :: Coercion}
|
||||
|
||||
changeCoercion :: ExplicitExpression -> Coercion -> ExplicitExpression
|
||||
changeCoercion ExplicitEmpty _ = ExplicitEmpty
|
||||
changeCoercion (ExplicitVariable n _) c = ExplicitVariable n c
|
||||
changeCoercion (Value n _) c = Value n c
|
||||
changeCoercion (ExplicitList e) _ = ExplicitList e
|
||||
changeCoercion (ExplicitKeyword n) _ = ExplicitKeyword n
|
||||
changeCoercion (ExplicitParens e) _ = ExplicitParens e
|
||||
changeCoercion (ExplicitPath s n _) c = ExplicitPath s n c
|
||||
changeCoercion (ExplicitFunction n args _) c = ExplicitFunction n args c
|
||||
changeCoercion (ExplicitIfSimple cond block _) c = ExplicitIfSimple cond block c
|
||||
changeCoercion (ExplicitIfElse cond block block2 _) c = ExplicitIfElse cond block block2 c
|
||||
|
||||
instance Show ExplicitExpression where
|
||||
show (ExplicitVariable name coer) = show $ "Variable: " ++ name
|
||||
show (Value name coer) = show $ "Value: " ++ name
|
||||
@@ -139,7 +151,8 @@ toHaskell :: Type -> Type
|
||||
toHaskell a
|
||||
| typeName a == "int" = BasicType "Integer"
|
||||
| typeName a == "boolean" = BasicType "Boolean"
|
||||
| typeName a == "real" = BasicType "Double"
|
||||
| typeName a == "number" = BasicType "Double"
|
||||
| typeName a == "string" = BasicType "String"
|
||||
| otherwise = a
|
||||
|
||||
coercionType :: [TypeCoercion] -> Type
|
||||
|
||||
@@ -69,7 +69,10 @@ listParser =
|
||||
variableParser :: Parser Expression
|
||||
variableParser =
|
||||
do
|
||||
Variable <$> camelNameParser
|
||||
name <- camelNameParser
|
||||
if name == "endDate," then error "lool"
|
||||
else return $ Variable name
|
||||
--Variable <$> camelNameParser
|
||||
|
||||
-- |Parses an integer in Rosetta into an Expression
|
||||
integerParser :: Parser Expression
|
||||
|
||||
@@ -5,45 +5,45 @@ module PrettyPrinter.Expression where
|
||||
import Model.Type
|
||||
import Prettyprinter
|
||||
import Semantic.ExpressionChecker(coercionIncluded)
|
||||
import Utils.Utils
|
||||
|
||||
printExpression :: ExplicitExpression -> Coercion -> Doc a
|
||||
printExpression ExplicitEmpty _ = "[]"
|
||||
printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of
|
||||
Left err -> error $ show coer ++ "//" ++ show out --err
|
||||
Right c -> printCoercion c $ pretty name
|
||||
printExpression (Value s coer) out = case coer `coercionIncluded` out of
|
||||
Left err -> error $ show err
|
||||
Right c -> printCoercion c $ pretty s
|
||||
printExpression (ExplicitKeyword k) out = pretty k
|
||||
printExpression (ExplicitParens ex) out = "(" <> printExpression ex out <> ")"
|
||||
printExpression (ExplicitList ex) out = list [printExpression x out | x <- ex]
|
||||
printExpression (ExplicitPath ex1 ex2 returnCoerce) out = printCoercion (returnCoercion ex1) (printExpression ex1 (returnCoercion ex1)) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2 out)
|
||||
printExpression (ExplicitFunction "exists" args returnCoerce) out = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "is absent" args returnCoerce) out = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "single exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> "1"
|
||||
printExpression (ExplicitFunction "multiple exists" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> ">" <+> "1"
|
||||
printExpression (ExplicitFunction "count" args returnCoerce) out = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression :: ExplicitExpression -> Doc a
|
||||
printExpression ExplicitEmpty = "[]"
|
||||
printExpression (ExplicitVariable name coer) = printCoercion coer $ pretty name
|
||||
printExpression (Value s coer) = printCoercion coer $ pretty s
|
||||
printExpression (ExplicitKeyword k) = pretty k
|
||||
printExpression (ExplicitParens ex) = "(" <> printExpression ex <> ")"
|
||||
printExpression (ExplicitList ex) = list [printExpression x | x <- ex]
|
||||
printExpression (ExplicitPath ex1 ex2 returnCoerce) = printCoercion (returnCoercion ex1) (printExpression ex1) <+> "->" <+> printCoercion (returnCoercion ex2) (printExpression ex2)
|
||||
printExpression (ExplicitFunction "exists" args returnCoerce) = printCoercion returnCoerce "isJust" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
printExpression (ExplicitFunction "is absent" args returnCoerce) = printCoercion returnCoerce "isNothing" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
printExpression (ExplicitFunction "single exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> "1"
|
||||
printExpression (ExplicitFunction "multiple exists" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> ">" <+> "1"
|
||||
printExpression (ExplicitFunction "count" args returnCoerce) = printCoercion returnCoerce "length" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
-- Equality expressions
|
||||
-- [a] a all =
|
||||
-- any <>
|
||||
printExpression (ExplicitFunction "=" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "<>" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "any =" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "all <>" args returnCoerce) out = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "all =" args returnCoerce) out = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out) <+> printCoercion (snd $ head args) (printExpression (fst $ head args) out)
|
||||
printExpression (ExplicitFunction "and" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction "or" args returnCoerce) out = printCoercion (snd $ head args) (printExpression (fst $ head args) out) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args) out)
|
||||
printExpression (ExplicitFunction name args returnCoerce) out = pretty name <+> tupled (zipWith printCoercion [c | (e,c) <- args] [printExpression e out | (e, c) <- args])
|
||||
printExpression (ExplicitIfSimple cond thenBlock returnCoercion) out =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+>
|
||||
"else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` out of
|
||||
printExpression (ExplicitFunction "=" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "==" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
|
||||
printExpression (ExplicitFunction "<>" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "/=" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
|
||||
printExpression (ExplicitFunction "any =" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`elem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
printExpression (ExplicitFunction "all <>" args returnCoerce) = printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> "`notElem`" <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
printExpression (ExplicitFunction "all =" args returnCoerce) = "all (Eq)" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args)) <+> printCoercion (snd $ head args) (printExpression (fst $ head args))
|
||||
printExpression (ExplicitFunction "and" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "&&" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
|
||||
printExpression (ExplicitFunction "or" args returnCoerce) = printCoercion (snd $ head args) (printExpression (fst $ head args)) <+> "||" <+> printCoercion (snd $ head $ tail args) (printExpression (fst $ head $ tail args))
|
||||
printExpression (ExplicitFunction name args returnCoerce) =
|
||||
if null printedArgs then pretty (uncapitalize name)
|
||||
else "(" <> pretty (uncapitalize name) <+> printCoercion returnCoerce (hsep printedArgs) <> ")"
|
||||
where printedArgs = zipWith printCoercion [c | (e,c) <- args] [printExpression e | (e, c) <- args]
|
||||
printExpression (ExplicitIfSimple cond thenBlock returnCoercion) =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+>
|
||||
"else" <+> case MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion returnCoercion] (MakeCardinalityIdCoercion (Bounds (0, 0))) `coercionIncluded` returnCoercion of
|
||||
Left err -> error $ show err
|
||||
Right c -> printCoercion c emptyDoc
|
||||
printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) out =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond) (MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))))) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock) out) <+>
|
||||
"else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock) out)
|
||||
printExpression (ExplicitIfElse cond thenBlock elseBlock returnCoercion) =
|
||||
"if" <+> printCoercion (snd cond) (printExpression (fst cond)) <+>
|
||||
"then" <+> printCoercion (snd thenBlock) (printExpression (fst thenBlock)) <+>
|
||||
"else" <+> printCoercion (snd elseBlock) (printExpression (fst elseBlock))
|
||||
|
||||
-- |Converts a coercion into a haskell string
|
||||
printCoercion :: Coercion -> Doc a -> Doc a
|
||||
|
||||
@@ -8,7 +8,7 @@ import Model.Function
|
||||
import PrettyPrinter.General
|
||||
import PrettyPrinter.Type
|
||||
import Model.Type
|
||||
import Utils.Utils (uncapitalize)
|
||||
import Utils.Utils (capitalize, uncapitalize)
|
||||
|
||||
{-
|
||||
Consider all assignments as trees
|
||||
@@ -42,7 +42,7 @@ printFunction f = show $ vcat [printFunctionSignature (sign f), printFunctionBod
|
||||
printFunctionBody :: ExplicitFunction -> Doc a
|
||||
printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) =
|
||||
pretty name <+> printVariableNames inp <+> "=" <+>
|
||||
printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]) (returnCoercion (fst $ head ex))
|
||||
printAssignmentTree (head $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex])
|
||||
--error $ show $ mergeAssignmentTrees [convertToAssignmentTree (fst exp) (AssignmentLeaf (snd exp)) | exp <- ex]
|
||||
|
||||
|
||||
@@ -55,15 +55,19 @@ printFunctionSignature (MakeFunctionSignature name description inputs output) =
|
||||
prettyPrintType :: [Doc x] -> Doc x
|
||||
prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->")
|
||||
|
||||
printAssignmentTree :: AssignmentTree -> Coercion -> Doc a
|
||||
printAssignmentTree (AssignmentLeaf exp) coer = printExpression exp coer
|
||||
printAssignmentTree (AssignmentNode var typ c) coer
|
||||
printAssignmentTree :: AssignmentTree -> Doc a
|
||||
printAssignmentTree (AssignmentLeaf exp) = printExpression exp
|
||||
printAssignmentTree (AssignmentNode var typ c)
|
||||
| length c == 1 = case head c of
|
||||
AssignmentLeaf e -> printConstructor typ <+> "(" <+> printAssignmentTree (head c) coer <> ")"
|
||||
AssignmentNode v t _ -> printConstructor typ <> printConstructor t <+> "(" <+> printAssignmentTree (head c) coer <> ")"
|
||||
AssignmentLeaf e -> printAssignmentTree (head c)
|
||||
AssignmentNode v t _ -> printConstructor typ <> pretty (capitalize v) <+> "(" <> printAssignmentTree (head c) <> ")"
|
||||
| otherwise = case typ of
|
||||
MakeType t _ _ _ _ -> "Make" <> pretty t <+> group (sep [printAssignmentTree child coer | child <- c])
|
||||
BasicType _ -> sep [printAssignmentTree child coer | child <- c]
|
||||
MakeType t _ _ _ _ -> "Make" <> pretty t <+> "{" <> hsep (punctuate "," [pretty (uncapitalize t) <> getVarName child <+> "=" <+> printAssignmentTree child | child <- c]) <> "}"
|
||||
BasicType _ -> sep ["(" <> printAssignmentTree child <> ")" | child <- c]
|
||||
|
||||
getVarName :: AssignmentTree -> Doc a
|
||||
getVarName (AssignmentLeaf _) = emptyDoc
|
||||
getVarName (AssignmentNode var _ _) = pretty (capitalize var)
|
||||
|
||||
mergeAssignmentTrees :: [AssignmentTree] -> [AssignmentTree]
|
||||
mergeAssignmentTrees [] = []
|
||||
|
||||
@@ -254,7 +254,7 @@ getTypeAttributes (defT : ts) t
|
||||
| typeName defT == typeName t =
|
||||
[MakeTypeAttribute {attributeName = attributeName attr,
|
||||
attributeType = toHaskell (attributeType attr),
|
||||
Model.Type.cardinality = Model.Type.cardinality attr,
|
||||
Model.Type.cardinality = if MakeCondition Nothing (Keyword "one-of") `elem` conditions defT then Bounds (1,1) else Model.Type.cardinality attr,
|
||||
attributeDescription = attributeDescription attr}
|
||||
| attr <- typeAttributes defT]
|
||||
| otherwise = getTypeAttributes ts t
|
||||
|
||||
@@ -24,12 +24,15 @@ checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name
|
||||
|
||||
checkAssignment :: [Type] -> [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)]
|
||||
checkAssignment _ _ [] = Right []
|
||||
checkAssignment defT symbs ((assign, ex): assigns) =
|
||||
checkAssignment defT symbs ((assign, ex): assigns) =
|
||||
case checkExpression defT (tail symbs) ex of
|
||||
Left err -> Left [err]
|
||||
-- Here we use only tail symbs, beacuse the head of the symbol table is the out variable, and that can't be used in the expression body
|
||||
Right checkedExp -> case checkExpression defT symbs assign of
|
||||
Left err -> Left [err]
|
||||
Right checkedA -> case checkAssignment defT symbs assigns of
|
||||
Left err -> Left err
|
||||
Right checked -> Right $ (checkedA, checkedExp) : checked
|
||||
Left err -> Left err
|
||||
-- Add a final explicit transformation to match the expected output
|
||||
Right checked -> case returnCoercion checkedExp `coercionIncluded` returnCoercion checkedA of
|
||||
Left err -> Left [err]
|
||||
Right c -> Right $ (checkedA, changeCoercion checkedExp c) : checked
|
||||
@@ -47,27 +47,6 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) =
|
||||
Left err -> Left err : checkAttributes definedTypes as
|
||||
Right checked -> Right (MakeTypeAttribute name checked crd desc) : checkAttributes definedTypes as
|
||||
|
||||
populateAttributeType :: [Type] -> [Type] -> TypeAttribute -> Either TypeCheckError TypeAttribute
|
||||
populateAttributeType _ _ (MakeTypeAttribute n (MakeType "int" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Integer") c d
|
||||
populateAttributeType _ _ (MakeTypeAttribute n (MakeType "string" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "String") c d
|
||||
populateAttributeType _ _ (MakeTypeAttribute n (MakeType "number" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Double") c d
|
||||
populateAttributeType _ _ (MakeTypeAttribute n (MakeType "boolean" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Bool") c d
|
||||
populateAttributeType _ _ (MakeTypeAttribute n (MakeType "time" _ _ _ _) c d ) = Right $ MakeTypeAttribute n (BasicType "Time") c d
|
||||
populateAttributeType _ _ (MakeTypeAttribute n (BasicType t) c d) = Right $ MakeTypeAttribute n (BasicType t) c d
|
||||
populateAttributeType _ [] t = Left $ UndefinedType $ typeName $ attributeType t
|
||||
populateAttributeType t (definedT : ts) typ
|
||||
| definedT == attributeType typ =
|
||||
let populatedAttr = map (populateAttributeType t t) (typeAttributes definedT)
|
||||
in
|
||||
if null $ lefts populatedAttr
|
||||
then Right $ MakeTypeAttribute
|
||||
(attributeName typ)
|
||||
(MakeType (typeName definedT) (superType definedT) (typeDescription definedT) (rights populatedAttr) (conditions definedT))
|
||||
(cardinality typ)
|
||||
(attributeDescription typ)
|
||||
else Left $ head $ lefts populatedAttr
|
||||
| otherwise = populateAttributeType t ts typ
|
||||
|
||||
-- |Checks whether a type is predefined or in the symbol table
|
||||
checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type
|
||||
checkAttributeType [] t = Left $ UndefinedType $ typeName t
|
||||
|
||||
Reference in New Issue
Block a user