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 Data.Text (Text)
-- :l resources/Generated/testMultiple.hs
-- :set args resources/Rosetta/test-multiple.rosetta
-- :set args resources/Rosetta/test-all.rosetta
@@ -64,12 +65,9 @@ parseWithImport file =
let importedFunctions = concat $ sndlst importedSymbolTable
case addNewTypes importedTypes objs of
Left errors -> error $ show errors
Right emptyTypes ->
case populateTypes emptyTypes of
Left errors -> error $ show errors
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
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
parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject])

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

@@ -21,3 +21,45 @@ func ExchangeRateFunc:
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 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 ExplicitEmpty _ = "[]"
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
printExpression (Value s coer) out = case coer `coercionIncluded` out of
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
-- |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 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)))
checkExpression _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0)))
checkExpression _ (Keyword k) = Right $ ExplicitKeyword k
checkExpression symbolMap (PathExpression ex1 (Variable b)) =
case checkExpression symbolMap ex1 of
checkExpression defT 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)))
checkExpression _ _ Empty = Right $ Value "empty" $ MakeCoercion [MakeIdCoercion (BasicType "Empty")] (MakeCardinalityIdCoercion (Bounds (0, 0)))
checkExpression _ _ (Keyword k) = Right $ ExplicitKeyword k
checkExpression defT symbolMap (PathExpression ex1 (Variable b)) =
case checkExpression defT symbolMap ex1 of
Left err -> Left err
Right exp1 -> case findAttributeType b (typeAttributes type1) of
Left err -> Left $ UndefinedVariable $ show ex1 ++ " -> " ++ b
Right exp1 -> case findAttributeType b (getTypeAttributes defT type1) of
Left err -> Left $ UndefinedVariable $ show type1 ++ " -> " ++ b
Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2)
where
type1 = coercionType $ typeCoercion $ 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 _ _ (PathExpression _ ex) = Left $ UnsupportedExpressionInPathExpression $ show ex
--checkExpression symbolMap (PathExpression ex1 (PathExpression ))
checkExpression symbolMap (Parens ex) =
case checkExpression symbolMap ex of
checkExpression defT symbolMap (Parens ex) =
case checkExpression defT symbolMap ex of
Left err -> Left err
Right exp -> Right $ ExplicitParens exp
checkExpression symbolMap (List lst) = checkList symbolMap lst
checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
checkExpression symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression symbolMap) exps)
checkExpression symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression symbolMap ex]
checkExpression symbolMap (InfixExp name ex1 ex2) = checkFunctionCall symbolMap name (checkExpression symbolMap ex1: [checkExpression symbolMap ex2])
checkExpression defT symbolMap (List lst) = checkList defT symbolMap lst
checkExpression defT symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name [checkExpression defT symbolMap ex]
checkExpression defT symbolMap (Function name exps) = checkFunctionCall symbolMap name (map (checkExpression defT symbolMap) exps)
checkExpression defT symbolMap (PostfixExp name ex) = checkFunctionCall symbolMap name [checkExpression defT symbolMap ex]
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
checkExpression symbolMap (IfSimple cond ex) =
case checkExpression symbolMap cond of
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)
Right condCoerce ->
case checkExpression symbolMap ex of
case checkExpression defT symbolMap ex of
Left err -> Left err
Right thenExp ->
Right $ ExplicitIfSimple (condType, condCoerce)
@@ -132,15 +132,15 @@ checkExpression symbolMap (IfSimple cond ex) =
(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
checkExpression symbolMap (IfElse cond ex1 ex2) =
case checkExpression symbolMap cond of
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)
Right condCoerce ->
case checkExpression symbolMap ex1 of
case checkExpression defT symbolMap ex1 of
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
Right elseExp ->
Right $ ExplicitIfElse (condType, condCoerce)
@@ -152,27 +152,27 @@ checkExpression symbolMap (IfElse cond ex1 ex2) =
-- |TODO Handle nested lists and lists with parens
-- |Checks that all the expressions in a list have compatible types
checkList :: [Symbol] -> [Expression] -> Either TypeCheckError ExplicitExpression
checkList _ [] = Right $ ExplicitList [ExplicitEmpty]
checkList symbs (ex : exps) =
case checkExpression symbs ex of
checkList :: [Type] -> [Symbol] -> [Expression] -> Either TypeCheckError ExplicitExpression
checkList _ _ [] = Right $ ExplicitList [ExplicitEmpty]
checkList defT symbs (ex : exps) =
case checkExpression defT symbs ex of
Left err -> Left err
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
Right exp -> Right $ ExplicitList exp
-- |Auxiliary function for the check list function
checkList1 :: [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression]
checkList1 _ [] typ = Right [ExplicitEmpty]
checkList1 symbs (ex : exps) typ =
case checkExpression symbs ex of
checkList1 :: [Type] -> [Symbol] -> [Expression] -> (Type, Cardinality) -> Either TypeCheckError [ExplicitExpression]
checkList1 _ _ [] typ = Right [ExplicitEmpty]
checkList1 defT symbs (ex : exps) typ =
case checkExpression defT symbs ex of
Left err -> Left err
Right exCo ->
case fst typ `isSubType` exTyp of
Left err -> Left err
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
Right explicitEx -> Right [ExplicitList explicitEx]
where
@@ -247,6 +247,18 @@ isSubType x y
Left e -> Left e
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
cardinalityIncluded :: Cardinality -> Cardinality -> Either TypeCheckError CardinalityCoercion
-- |Special Cases

14
src/Semantic/FunctionChecker.hs
View File

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