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

fixed recursive types

Browse Source
This commit is contained in:
Macocian Adrian Radu
2022-05-16 12:55:36 +02:00
parent 1cdb56f5ee
commit 05d5bf3681
6 changed files with 103 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
app/Main.hs
View File

@@ -26,6 +26,7 @@ import Data.Void
import Utils.Utils import Utils.Utils
import Data.Text (Text) import Data.Text (Text)
-- :l resources/Generated/testMultiple.hs
-- :set args resources/Rosetta/test-multiple.rosetta -- :set args resources/Rosetta/test-multiple.rosetta
-- :set args resources/Rosetta/test-all.rosetta -- :set args resources/Rosetta/test-all.rosetta
@@ -64,12 +65,9 @@ parseWithImport file =
let importedFunctions = concat $ sndlst importedSymbolTable let importedFunctions = concat $ sndlst importedSymbolTable
case addNewTypes importedTypes objs of case addNewTypes importedTypes objs of
Left errors -> error $ show errors Left errors -> error $ show errors
Right emptyTypes -> Right definedTypes -> case addNewFunctions (definedTypes, importedFunctions) objs of
case populateTypes emptyTypes of Left errors -> error $ show errors
Left errors -> error $ show errors Right definedFunctions -> return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports
Right definedTypes -> case addNewFunctions (definedTypes, importedFunctions) objs of
Left errors -> error $ show errors
Right definedFunctions -> return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports
-- |Parse a file into a list of RosettaObjects -- |Parse a file into a list of RosettaObjects
parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject]) parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject])

44
resources/Rosetta/test-multiple.rosetta
View File

@@ -20,4 +20,46 @@ func ExchangeRateFunc:
assign-output observable -> exchangeRate -> from: assign-output observable -> exchangeRate -> from:
from from
assign-output observable -> exchangeRate -> to: assign-output observable -> exchangeRate -> to:
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 int (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)

2
src/PrettyPrinter/Expression.hs
View File

@@ -9,7 +9,7 @@ import Semantic.ExpressionChecker(coercionIncluded)
printExpression :: ExplicitExpression -> Coercion -> Doc a printExpression :: ExplicitExpression -> Coercion -> Doc a
printExpression ExplicitEmpty _ = "[]" printExpression ExplicitEmpty _ = "[]"
printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of printExpression (ExplicitVariable name coer) out = case coer `coercionIncluded` out of
Left err -> error $ show err Left err -> error $ show coer ++ "//" ++ show out --err
Right c -> printCoercion c $ pretty name Right c -> printCoercion c $ pretty name
printExpression (Value s coer) out = case coer `coercionIncluded` out of printExpression (Value s coer) out = case coer `coercionIncluded` out of
Left err -> error $ show err Left err -> error $ show err

84
src/Semantic/ExpressionChecker.hs
View File

@@ -85,42 +85,42 @@ addVariables s [] = s
addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskell typ) crd : addVariables s vars addVariables s ((MakeTypeAttribute name typ crd _) : vars) = Var name (toHaskell typ) crd : addVariables s vars
-- |Checks the type of a given expression -- |Checks the type of a given expression
checkExpression :: [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression checkExpression :: [Type] -> [Symbol] -> Expression -> Either TypeCheckError ExplicitExpression
--checkExpression sym _ = error $ show sym --checkExpression sym _ = error $ show sym
checkExpression symbolMap (Variable var) = findVarType var symbolMap checkExpression defT symbolMap (Variable var) = findVarType var symbolMap
checkExpression _ (Int val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Integer")] (MakeCardinalityIdCoercion (Bounds (1, 1))) 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 _ _ (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))) checkExpression _ _ (Boolean val) = Right $ Value val $ MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1)))
checkExpression _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0))) checkExpression _ _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0)))
checkExpression _ (Keyword k) = Right $ ExplicitKeyword k checkExpression _ _ (Keyword k) = Right $ ExplicitKeyword k
checkExpression symbolMap (PathExpression ex1 (Variable b)) = checkExpression defT symbolMap (PathExpression ex1 (Variable b)) =
case checkExpression symbolMap ex1 of case checkExpression defT symbolMap ex1 of
Left err -> Left err Left err -> Left err
Right exp1 -> case findAttributeType b (typeAttributes type1) of Right exp1 -> case findAttributeType b (getTypeAttributes defT type1) of
Left err -> Left $ UndefinedVariable $ show ex1 ++ " -> " ++ b Left err -> Left $ UndefinedVariable $ show type1 ++ " -> " ++ b
Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2) Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2)
where where
type1 = coercionType $ typeCoercion $ returnCoercion exp1 type1 = coercionType $ typeCoercion $ returnCoercion exp1
-- |Getting here means that an expression is used inside a path expression and this is not supported -- |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 _ _ (PathExpression _ ex) = Left $ UnsupportedExpressionInPathExpression $ show ex
--checkExpression symbolMap (PathExpression ex1 (PathExpression )) --checkExpression symbolMap (PathExpression ex1 (PathExpression ))
checkExpression symbolMap (Parens ex) = checkExpression defT symbolMap (Parens ex) =
case checkExpression symbolMap ex of case checkExpression defT symbolMap ex of
Left err -> Left err Left err -> Left err
Right exp -> Right $ ExplicitParens exp Right exp -> Right $ ExplicitParens exp
checkExpression symbolMap (List lst) = checkList symbolMap lst checkExpression defT symbolMap (List lst) = checkList defT symbolMap lst
checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression defT symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression defT symbolMap ex]
checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps) checkExpression defT symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression defT symbolMap) exps)
checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex] checkExpression defT symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression defT symbolMap ex]
checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2]) checkExpression defT symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression defT symbolMap ex1: [checkExpression defT symbolMap ex2])
-- |Checks if the condition of an if expression is of type boolean, and then checks the expression of the then statement -- |Checks if the condition of an if expression is of type boolean, and then checks the expression of the then statement
checkExpression symbolMap (IfSimple cond ex) = checkExpression defT symbolMap (IfSimple cond ex) =
case checkExpression symbolMap cond of case checkExpression defT symbolMap cond of
Left err -> Left $ IfConditionNotBoolean $ show err Left err -> Left $ IfConditionNotBoolean $ show err
Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of 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 (coercionType $ typeCoercion $ returnCoercion condType)
Right condCoerce -> Right condCoerce ->
case checkExpression symbolMap ex of case checkExpression defT symbolMap ex of
Left err -> Left err Left err -> Left err
Right thenExp -> Right thenExp ->
Right $ ExplicitIfSimple (condType, condCoerce) Right $ ExplicitIfSimple (condType, condCoerce)
@@ -132,15 +132,15 @@ checkExpression symbolMap (IfSimple cond ex) =
(MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion 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 -- |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
checkExpression symbolMap (IfElse cond ex1 ex2) = checkExpression defT symbolMap (IfElse cond ex1 ex2) =
case checkExpression symbolMap cond of case checkExpression defT symbolMap cond of
Left err -> Left $ IfConditionNotBoolean $ show err Left err -> Left $ IfConditionNotBoolean $ show err
Right condType -> case returnCoercion condType `coercionIncluded` MakeCoercion [MakeIdCoercion (BasicType "Boolean")] (MakeCardinalityIdCoercion (Bounds (1, 1))) of 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 (coercionType $ typeCoercion $ returnCoercion condType)
Right condCoerce -> Right condCoerce ->
case checkExpression symbolMap ex1 of case checkExpression defT symbolMap ex1 of
Left err -> Left $ ErrorInsideFunction $ show err Left err -> Left $ ErrorInsideFunction $ show err
Right thenExp -> case checkExpression symbolMap ex2 of Right thenExp -> case checkExpression defT symbolMap ex2 of
Left err -> Left $ ErrorInsideFunction $ show err Left err -> Left $ ErrorInsideFunction $ show err
Right elseExp -> Right elseExp ->
Right $ ExplicitIfElse (condType, condCoerce) Right $ ExplicitIfElse (condType, condCoerce)
@@ -152,27 +152,27 @@ checkExpression symbolMap (IfElse cond ex1 ex2) =
-- |TODO Handle nested lists and lists with parens -- |TODO Handle nested lists and lists with parens
-- |Checks that all the expressions in a list have compatible types -- |Checks that all the expressions in a list have compatible types
checkList :: [Symbol] -> [Expression] -> Either TypeCheckError ExplicitExpression checkList :: [Type] -> [Symbol] -> [Expression] -> Either TypeCheckError ExplicitExpression
checkList _ [] = Right $ ExplicitList [ExplicitEmpty] checkList _ _ [] = Right $ ExplicitList [ExplicitEmpty]
checkList symbs (ex : exps) = checkList defT symbs (ex : exps) =
case checkExpression symbs ex of case checkExpression defT symbs ex of
Left err -> Left err Left err -> Left err
Right x -> Right x ->
case checkList1 symbs exps (coercionType $ typeCoercion $ returnCoercion x, toCardinality $ cardinalityCoercion $ returnCoercion x) of case checkList1 defT symbs exps (coercionType $ typeCoercion $ returnCoercion x, toCardinality $ cardinalityCoercion $ returnCoercion x) of
Left err -> Left err Left err -> Left err
Right exp -> Right $ ExplicitList exp Right exp -> Right $ ExplicitList exp
-- |Auxiliary function for the check list function -- |Auxiliary function for the check list function
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression] checkList1 :: [Type] -> [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression]
checkList1 _ [] typ = Right [ExplicitEmpty] checkList1 _ _ [] typ = Right [ExplicitEmpty]
checkList1 symbs (ex : exps) typ = checkList1 defT symbs (ex : exps) typ =
case checkExpression symbs ex of case checkExpression defT symbs ex of
Left err -> Left err Left err -> Left err
Right exCo -> Right exCo ->
case fst typ `isSubType` exTyp of case fst typ `isSubType` exTyp of
Left err -> Left err Left err -> Left err
Right _ -> Right _ ->
case checkList1 symbs exps (exTyp, smallestBound exCard (snd typ)) of case checkList1 defT symbs exps (exTyp, smallestBound exCard (snd typ)) of
Left err -> Left err Left err -> Left err
Right explicitEx -> Right [ExplicitList explicitEx] Right explicitEx -> Right [ExplicitList explicitEx]
where where
@@ -247,6 +247,18 @@ isSubType x y
Left e -> Left e Left e -> Left e
Right transforms -> Right $ MakeSuperCoercion x y : transforms Right transforms -> Right $ MakeSuperCoercion x y : transforms
-- |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 =
[MakeTypeAttribute {attributeName = attributeName attr,
attributeType = toHaskell (attributeType attr),
Model.Type.cardinality = Model.Type.cardinality attr,
attributeDescription = attributeDescription attr}
| attr <- typeAttributes defT]
| otherwise = getTypeAttributes ts t
-- |Checks whether the first cardinality is included into the second one -- |Checks whether the first cardinality is included into the second one
cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError CardinalityCoercion cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError CardinalityCoercion
-- |Special Cases -- |Special Cases

14
src/Semantic/FunctionChecker.hs
View File

@@ -16,20 +16,20 @@ checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name
then then
case head $ checkAttributes definedTypes [out] of case head $ checkAttributes definedTypes [out] of
Left err -> Left [err] Left err -> Left [err]
Right checkedOut -> case checkAssignment (addVariables symbols (checkedOut : rights checkedIn)) ex of Right checkedOut -> case checkAssignment definedTypes (addVariables symbols (checkedOut : rights checkedIn)) ex of
Left err -> Left err Left err -> Left err
Right checkedEx -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) checkedEx Right checkedEx -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) checkedEx
else else
Left $ lefts checkedIn Left $ lefts checkedIn
checkAssignment :: [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)] checkAssignment :: [Type] -> [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)]
checkAssignment _ [] = Right [] checkAssignment _ _ [] = Right []
checkAssignment symbs ((assign, ex): assigns) = checkAssignment defT symbs ((assign, ex): assigns) =
case checkExpression (tail symbs) ex of case checkExpression defT (tail symbs) ex of
Left err -> Left [err] 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 -- 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 symbs assign of Right checkedExp -> case checkExpression defT symbs assign of
Left err -> Left [err] Left err -> Left [err]
Right checkedA -> case checkAssignment symbs assigns of Right checkedA -> case checkAssignment defT symbs assigns of
Left err -> Left err Left err -> Left err
Right checked -> Right $ (checkedA, checkedExp) : checked Right checked -> Right $ (checkedA, checkedExp) : checked

24
src/Semantic/TypeChecker.hs
View File

@@ -80,30 +80,6 @@ checkAttributeType (defined : ts) t
| defined == t = Right defined | defined == t = Right defined
| otherwise = checkAttributeType ts t | otherwise = checkAttributeType ts t
populateTypes :: [Type] -> Either [TypeCheckError] [Type]
populateTypes t = populateTypes1 t t
populateTypes1 :: [Type] -> [Type] -> Either [TypeCheckError] [Type]
populateTypes1 _ [] = Right []
populateTypes1 emptyTypes (BasicType t : ts) =
case populateTypes1 emptyTypes ts of
Left error -> Left error
Right definedTypes -> Right $ BasicType t : definedTypes
populateTypes1 emptyTypes (t : ts) =
case populateTypes1 emptyTypes ts of
Left error -> Left error
Right definedTypes ->
let populated = map (populateAttributeType emptyTypes emptyTypes) (typeAttributes t) in
if null $ lefts populated
then Right $ MakeType
(typeName t)
(superType t)
(typeDescription t)
(rights populated)
(conditions t) : definedTypes
else
Left $ lefts populated
-- |Add a list of defined types to the symbol table -- |Add a list of defined types to the symbol table
addDefinedTypes :: [Type] -> [Type] -> Either [TypeCheckError] [Type] addDefinedTypes :: [Type] -> [Type] -> Either [TypeCheckError] [Type]
addDefinedTypes l [] = Right l addDefinedTypes l [] = Right l