diff --git a/app/Main.hs b/app/Main.hs index a90f3bb..e7a8b60 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,6 +26,8 @@ import Data.Void import Utils.Utils import Data.Text (Text) +-- :set args resources/Rosetta/test-multiple.rosetta + -- :set args resources/Rosetta/test-all.rosetta -- :l resources/Generated/testAll.hs resources/Generated/testPeriod.hs @@ -62,10 +64,12 @@ parseWithImport file = let importedFunctions = concat $ sndlst importedSymbolTable case addNewTypes importedTypes objs of Left errors -> error $ show errors - Right definedTypes -> - case addNewFunctions (definedTypes, importedFunctions) objs of + Right emptyTypes -> + case populateTypes emptyTypes 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]) diff --git a/resources/Rosetta/test-all.rosetta b/resources/Rosetta/test-all.rosetta index 4cbbbe7..f650e4f 100644 --- a/resources/Rosetta/test-all.rosetta +++ b/resources/Rosetta/test-all.rosetta @@ -11,6 +11,8 @@ type TestSomeType: <"description"> type TestZeroOneType extends Period: testZeroOneType int (1..1) + condition important: <"This is an important condition"> + observationPrimitive < 0 type ObservationPrimitive: observationPrimitive int (1..1) diff --git a/resources/Rosetta/test-multiple.rosetta b/resources/Rosetta/test-multiple.rosetta new file mode 100644 index 0000000..597f344 --- /dev/null +++ b/resources/Rosetta/test-multiple.rosetta @@ -0,0 +1,23 @@ +namespace test.multiple : <"Something"> +version "${version.ok}" + + +type ExchangeRate: + from int (1..1) + to int (1..1) + +type Obs: + constant number (0..1) + exchangeRate ExchangeRate (0..1) + condition: one-of + +func ExchangeRateFunc: + inputs: + from int (1..1) + to int (1..1) + output: + observable Obs (1..1) + assign-output observable -> exchangeRate -> from: + from + assign-output observable -> exchangeRate -> to: + to \ No newline at end of file diff --git a/src/Model/Function.hs b/src/Model/Function.hs index 763a464..bb8e087 100644 --- a/src/Model/Function.hs +++ b/src/Model/Function.hs @@ -15,13 +15,13 @@ data FunctionSignature = data Function = MakeFunction { signature :: FunctionSignature, - assignment :: Expression + assignment :: [(Expression, Expression)] } deriving (Show) data ExplicitFunction = MakeExplicitFunction { sign :: FunctionSignature, - explicitAssignment :: ExplicitExpression + explicitAssignment :: [(ExplicitExpression, ExplicitExpression)] } deriving Show \ No newline at end of file diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 872f708..9ac5f06 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -22,13 +22,13 @@ instance Eq Type where (==) _ _ = False data Condition = MakeCondition { - conditionName :: String, conditionDescription :: Maybe String, expressionExpression :: Expression } deriving (Show) -- |The representation of an expression data Expression = Variable String + | PathExpression Expression Expression | Int String | Real String | Boolean String @@ -48,6 +48,7 @@ data ExplicitExpression = ExplicitEmpty | Value {name :: String, returnCoercion :: Coercion} | ExplicitList [ExplicitExpression] | ExplicitParens ExplicitExpression + | ExplicitPath {super :: ExplicitExpression, sub :: ExplicitExpression, returnCoercion :: Coercion} | 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} diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 1ed606d..a53ddd5 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -12,7 +12,7 @@ import Text.Megaparsec.Char -- |Parses a complete Rosetta expression into an Expression type expressionParser :: Parser Expression -expressionParser = +expressionParser = choice [ ifParser, try functionCallParser, eqParser] @@ -46,7 +46,7 @@ ifParser = case els of Left _ -> return (IfSimple condition expr) Right _ -> expressionParser >>= \expr2 -> return (IfElse condition expr expr2) - + -- |Parses an expression between parentheses in Rosetta into an Expression parens :: Parser a -> Parser a parens = between (char '(') (char ')') @@ -69,16 +69,7 @@ listParser = variableParser :: Parser Expression variableParser = do - var <- camelNameParser - inner <- many innerVariableParser - return $ Variable (var ++ concatMap ("->" ++) inner) - --- |Parses an inner variable (a -> b) in Rosetta into an Expression -innerVariableParser :: Parser String -innerVariableParser = - do - _ <- lexeme $ string "->" - camelNameParser + Variable <$> camelNameParser -- |Parses an integer in Rosetta into an Expression integerParser :: Parser Expression @@ -86,7 +77,7 @@ integerParser = do nr <- lexeme $ some digitChar return $ Int nr - + -- |Parses a real number in Rosetta into an Expression decimalParser :: Parser Expression decimalParser = @@ -95,7 +86,7 @@ decimalParser = _ <- char '.' real <- lexeme $ many digitChar return $ Real $ nr ++ "." ++ real - + -- |Parses a boolean in Rosetta into an Expression booleanParser :: Parser Expression booleanParser = @@ -105,7 +96,7 @@ booleanParser = -- |Parses the empty statement in Rosetta into an Expression emptyParser :: Parser Expression -emptyParser = +emptyParser = do _ <- lexeme $ string "empty" return Empty @@ -114,7 +105,7 @@ emptyParser = terminalParser :: Parser Expression terminalParser = do - choice + choice [ prefixParser, parens expressionParser >>= \e -> return (Parens e), listParser, @@ -131,11 +122,11 @@ terminalParser = -- |Parses an prefix function statement in Rosetta into an Expression prefixParser :: Parser Expression -prefixParser = +prefixParser = do op <- lexeme $ choice $ fmap (try . string . Text.pack) prefixOperators PrefixExp (Text.unpack op) <$> expressionParser - + -- |List of prefix operators prefixOperators :: [String] prefixOperators = ["-", "not"] @@ -166,44 +157,55 @@ sumParser = -- |Parses a multiplication or division statement in Rosetta into an Expression factorParser :: Parser Expression -factorParser = - do +factorParser = + do p <- powerParser op <- lexeme $ observing (char '*' <|> char '/') case op of Left _ -> return p Right o -> factorParser >>= \ex -> return $ reverseExpression $ InfixExp [o] p ex --- |Parses a boolean statement in Rosetta into an Expression -boolOpParser :: Parser Expression -boolOpParser = - do - p <- postfixParser - op <- lexeme $ observing (string "or" <|> string "and") - case op of - Left _ -> return p - Right o -> boolOpParser >>= \ex -> return $ InfixExp (Text.unpack o) p ex - -- |Parses a power statement in Rosetta into an Expression powerParser :: Parser Expression -powerParser = +powerParser = do p <- boolOpParser op <- lexeme $ observing $ char '^' case op of Left _ -> return p Right _ -> powerParser >>= \ex -> return $ InfixExp "^" p ex - + +-- |Parses a boolean statement in Rosetta into an Expression +boolOpParser :: Parser Expression +boolOpParser = + do + p <- postfixParser + op <- lexeme $ observing (string "or" <|> string "and") + case op of + Left _ -> return p + Right o -> boolOpParser >>= \ex -> return $ InfixExp (Text.unpack o) p ex + -- |Parses a postfix function in Rosetta into an Expression postfixParser :: Parser Expression -postfixParser = +postfixParser = do - t <- terminalParser + 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 + +-- |Parses a path expression (a -> b) in Rosetta into an Expression +pathExpressionParser :: Parser Expression +pathExpressionParser = + do + var <- terminalParser + 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"] @@ -217,6 +219,7 @@ reverseExpression :: Expression -> Expression 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 e = e diff --git a/src/Parser/Function.hs b/src/Parser/Function.hs index 808d2d1..39d0243 100644 --- a/src/Parser/Function.hs +++ b/src/Parser/Function.hs @@ -20,15 +20,18 @@ functionParser = fDescription <- optional descriptionParser fInput <- inputAttributesParser fOutput <- outputAttributeParser - MakeFunction (MakeFunctionSignature fName fDescription fInput fOutput) <$> assignmentParser + MakeFunction (MakeFunctionSignature fName fDescription fInput fOutput) <$> many assignmentParser +-- parseTest assignmentParser (Text.pack "assign-output observable -> exchangeRate -> from: from") -- |Parses the output assignment statement from a function in Rosetta into an Expression -assignmentParser :: Parser Expression +assignmentParser :: Parser (Expression, Expression) assignmentParser = do _ <- lexeme $ string "assign-output" + out <- expressionParser _ <- lexeme $ char ':' - expressionParser + assignment <- expressionParser + return (out, assignment) -- |Parses the input attributes from a function statement in Rosetta into a list of TypeAttributes inputAttributesParser :: Parser [TypeAttribute] diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index b6dada3..7ff7745 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -50,10 +50,9 @@ cardinalityParser = try parseBounded <|> try parseSemiBounded conditionParser :: Parser Condition conditionParser = do _ <- lexeme $ string "condition" - name <- lexeme camelNameParser - _ <- lexeme $ char ':' description <- optional descriptionParser - MakeCondition name description <$> expressionParser + _ <- lexeme $ char ':' + MakeCondition description <$> expressionParser -- |Parses a bounded cardinality statement in Rosetta into a Cardinality parseBounded :: Parser Cardinality diff --git a/src/PrettyPrinter/Function.hs b/src/PrettyPrinter/Function.hs index d5cffcc..64e6cc2 100644 --- a/src/PrettyPrinter/Function.hs +++ b/src/PrettyPrinter/Function.hs @@ -17,17 +17,20 @@ 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) ex) = pretty name <+> printVariableNames inp <+> "=" <+> printExpression ex (createCoercion (attributeType out, Model.Type.cardinality out)) +printFunctionBody (MakeExplicitFunction (MakeFunctionSignature name _ inp out) ex) = pretty name <+> printVariableNames inp <+> "= where" + <+> vcat [printExpression (fst exp) (returnCoercion (fst exp)) <+> " = " + <+> printExpression (snd exp) (returnCoercion (fst exp)) |exp <- ex] 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--show 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 (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" diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index 0e16b42..75cd628 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -40,4 +40,4 @@ printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _) printCardinality (MakeTypeAttribute _ typ (OneBound _) _) = "[" <> pretty (typeName typ) <> "]" printCondition :: Condition -> Doc a -printCondition (MakeCondition name desc e) = printDescription desc ("--" <+> pretty name <+> pretty (show e)) \ No newline at end of file +printCondition (MakeCondition desc e) = printDescription desc ("--" <+> pretty (show e)) \ No newline at end of file diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index a9b7141..6f6c752 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -6,8 +6,7 @@ import Data.Maybe import Model.Type import Semantic.TypeChecker import Utils.Utils -import Model.Type (CardinalityCoercion(MakeNothing2MaybeCoercion, MakeNothing2ListCoercion, MakeMaybe2ListCoercion, MakeObject2MaybeCoercion, MakeObject2ListCoercion)) - + -- |A declared variable or function data Symbol = Var{ varName :: String, @@ -28,8 +27,8 @@ instance Eq Symbol where | name1 == name2 = True | otherwise = False (==) _ _ = False - - + + -- |A map of the predefined functions, their arguments and their return type defaultMap :: [Symbol] defaultMap = [ @@ -41,7 +40,7 @@ defaultMap = [ Func "multiple exists" [(BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)), Func "contains" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)), Func "disjoint" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds (1, 1)), - + Func "=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)), Func ">=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)), Func "<=" [(BasicType "Any", OneBound 0), (BasicType "Any", OneBound 0)] (BasicType "Boolean", Bounds(1, 1)), @@ -52,7 +51,7 @@ defaultMap = [ Func "all <>" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)), Func "any =" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)), Func "any <>" [(BasicType "Any", OneBound 0), (BasicType "Any", Bounds(1, 1))] (BasicType "Boolean", Bounds(1, 1)), - + Func "+" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)), Func "+" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)), Func "-" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)), @@ -63,7 +62,7 @@ defaultMap = [ Func "/" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)), Func "^" [(BasicType "Integer", Bounds (1, 1)), (BasicType "Integer", Bounds (1, 1))] (BasicType "Integer", Bounds (1, 1)), Func "^" [(BasicType "Double", Bounds (1, 1)), (BasicType "Double", Bounds (1, 1))] (BasicType "Double", Bounds (1, 1)), - + Func "count" [(BasicType "Any", OneBound 0)] (BasicType "Integer", Bounds (1, 1)) ] @@ -77,26 +76,38 @@ addFunction (definedTypes, definedSymbols) (MakeFunction (MakeFunctionSignature then Left [MultipleDeclarations name] else Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType checkedOutput, Model.Type.cardinality out) : definedSymbols else Left $ lefts checkedInputs - where + where checkedInputs = checkAttributes definedTypes inps - + -- |Adds a newly defined variable to the symbol table addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol] 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 symbolMap (Variable var) = findVarType var symbolMap +checkExpression :: [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 symbolMap (Parens ex) = +checkExpression symbolMap (PathExpression ex1 (Variable b)) = + case checkExpression symbolMap ex1 of + Left err -> Left err + Right exp1 -> case findAttributeType b (typeAttributes type1) of + Left err -> Left $ UndefinedVariable $ show type1--ex1 ++ " -> " ++ b + Right exp2 -> Right $ ExplicitPath exp1 exp2 (returnCoercion exp2) + where + type1 = coercionType $ typeCoercion $ returnCoercion exp1 +--checkExpression symbolMap (PathExpression ex1 (PathExpression )) +checkExpression symbolMap (Parens ex) = case checkExpression symbolMap ex of Left err -> Left err Right exp -> Right $ ExplicitParens exp -checkExpression symbolMap (List lst) = checkList symbolMap lst +-- |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 (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] @@ -107,16 +118,16 @@ checkExpression symbolMap (IfSimple cond ex) = 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 -> + Right condCoerce -> case checkExpression symbolMap ex of Left err -> Left err - Right thenExp -> - Right $ ExplicitIfSimple (condType, condCoerce) - (thenExp, thenCoercion) + Right thenExp -> + Right $ ExplicitIfSimple (condType, condCoerce) + (thenExp, thenCoercion) (MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp] (MakeCardinalityIdCoercion $ smallestBound (Bounds (0, 0)) (toCardinality $ cardinalityCoercion $ returnCoercion thenExp))) - where - thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp] + where + thenCoercion = MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ 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 @@ -125,19 +136,18 @@ checkExpression symbolMap (IfElse cond ex1 ex2) = 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 -> + Right condCoerce -> case checkExpression symbolMap ex1 of Left err -> Left $ ErrorInsideFunction $ show err Right thenExp -> case checkExpression symbolMap ex2 of Left err -> Left $ ErrorInsideFunction $ show err - Right elseExp -> - Right $ ExplicitIfElse (condType, condCoerce) + Right elseExp -> + Right $ ExplicitIfElse (condType, condCoerce) (thenExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion thenExp] (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion thenExp)) (elseExp, MakeCoercion [MakeIdCoercion $ coercionType $ typeCoercion $ returnCoercion elseExp] (MakeCardinalityIdCoercion $ toCardinality $ cardinalityCoercion $ returnCoercion elseExp)) (returnCoercion thenExp) --(typeMatch ex1Type ex2Type, smallestBound ex1Card ex2Type) - -- |TODO Handle nested lists and lists with parens -- |Checks that all the expressions in a list have compatible types @@ -146,39 +156,39 @@ checkList _ [] = Right $ ExplicitList [ExplicitEmpty] checkList symbs (ex : exps) = case checkExpression symbs ex of Left err -> Left err - Right x -> + Right x -> case checkList1 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 Left err -> Left err - Right exCo -> + Right exCo -> case fst typ `isSubType` exTyp of Left err -> Left err - Right _ -> + Right _ -> case checkList1 symbs exps (exTyp, smallestBound exCard (snd typ)) of Left err -> Left err - Right explicitEx -> Right [ExplicitList explicitEx] + Right explicitEx -> Right [ExplicitList explicitEx] where exTyp = coercionType $ typeCoercion $ returnCoercion 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 :: [Symbol] -> String -> [Either TypeCheckError ExplicitExpression ] -> Either TypeCheckError ExplicitExpression checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ show (rights args) ++ "]" checkFunctionCall ((Func n a r):symbolMap) name args | length (rights args) /= length args = Left $ ErrorInsideFunction (name ++ ": " ++ show args ++ show (lefts args)) - | name == n && all isRight coerce = Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r))) + | name == n && all isRight coerce = Right $ ExplicitFunction name (zip (rights args) (rights coerce)) (MakeCoercion [MakeIdCoercion (fst r)] (MakeCardinalityIdCoercion (snd r))) | otherwise = checkFunctionCall symbolMap name args - where + where argCoerce = map returnCoercion (rights args) coerce = zipWith coercionIncluded argCoerce (map createCoercion a) -checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args +checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args typeIncluded :: (Type, Cardinality) -> (Type, Cardinality) -> Either TypeCheckError Coercion typeIncluded (t1, c1) (t2, c2) = @@ -189,8 +199,8 @@ typeIncluded (t1, c1) (t2, c2) = Left err -> Left err Right cardCoercion -> Right $ MakeCoercion typeCoercion cardCoercion -coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion -coercionIncluded c1 c2 = (coercionType (typeCoercion c1), coercionCardinality [cardinalityCoercion c1]) `typeIncluded` (coercionType (typeCoercion c2), coercionCardinality [cardinalityCoercion c2]) +coercionIncluded :: Coercion -> Coercion -> Either TypeCheckError Coercion +coercionIncluded c1 c2 = (coercionType (typeCoercion c1), coercionCardinality [cardinalityCoercion c1]) `typeIncluded` (coercionType (typeCoercion c2), coercionCardinality [cardinalityCoercion c2]) -- |Finds the most specific super type of the two types typeMatch :: Type -> Type -> Type @@ -210,20 +220,27 @@ typeMatch x y = case x `isSubType` y of Right _ -> y -- |Looks in the symbol map for the type of a variable -findVarType :: String -> [Symbol] -> Either TypeCheckError ExplicitExpression +findVarType :: String -> [Symbol] -> Either TypeCheckError ExplicitExpression findVarType var [] = Left $ UndefinedVariable var findVarType x ((Var name typ crd):symbols) | x == name = Right $ ExplicitVariable x (MakeCoercion [MakeIdCoercion typ] (MakeCardinalityIdCoercion crd)) | otherwise = findVarType x symbols findVarType x (_:symbols) = findVarType x symbols +-- |Find whether there is a attribute with the given name in the given type, and returns the attribute's type +findAttributeType :: String -> [TypeAttribute] -> Either TypeCheckError ExplicitExpression +findAttributeType var [] = Left $ UndefinedVariable var +findAttributeType var (t : ts) + | var == attributeName t = Right $ ExplicitVariable var (MakeCoercion [MakeIdCoercion $ attributeType t] (MakeCardinalityIdCoercion $ Model.Type.cardinality t)) + | otherwise = findAttributeType var ts + -- |Checks whether the first argument is a subtype of the second argument isSubType :: Type -> Type -> Either TypeCheckError [TypeCoercion] isSubType (BasicType "Integer") (BasicType "Double") = Right [MakeTypeCoercion (BasicType "Integer") (BasicType "Double") "fromInteger"] -isSubType (BasicType x) y +isSubType (BasicType x) y | x == typeName y = Right [MakeIdCoercion y] - | otherwise = Left $ TypeMismatch x (typeName y) -isSubType x y + | otherwise = Left $ TypeMismatch x (typeName y) +isSubType x y | typeName x == typeName y = Right [MakeIdCoercion x] | otherwise = case isSubType (superType x) y of Left e -> Left e diff --git a/src/Semantic/FunctionChecker.hs b/src/Semantic/FunctionChecker.hs index 141d2e5..9b0e0cb 100644 --- a/src/Semantic/FunctionChecker.hs +++ b/src/Semantic/FunctionChecker.hs @@ -11,16 +11,25 @@ import Utils.Utils -- |Checks if all the inputs and the output of a function call have valid types, and then checks that the assign-output expression is valid checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] ExplicitFunction checkFunction (definedTypes, symbols) (MakeFunction (MakeFunctionSignature name desc inp out) ex) = + let checkedIn = checkAttributes definedTypes inp in if null $ lefts checkedIn then case head $ checkAttributes definedTypes [out] of Left err -> Left [err] - Right checkedOut -> case checkExpression (addVariables symbols inp) ex of - Left err -> Left [err] - Right checkedEx -> case returnCoercion checkedEx `coercionIncluded` createCoercion (attributeType checkedOut, Model.Type.cardinality out) of - Left err -> Left [err] - Right retCoercion -> Right $ MakeExplicitFunction (MakeFunctionSignature (toLower (head name) : tail name) desc (rights checkedIn) checkedOut) checkedEx - --Right _ -> error $ show (returnCoercion checkedEx) ++ " // " ++ show (createCoercion (attributeType checkedOut, Model.Type.cardinality out)) + Right checkedOut -> case checkAssignment (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 - where checkedIn = checkAttributes definedTypes inp \ No newline at end of file + +checkAssignment :: [Symbol] -> [(Expression, Expression)] -> Either [TypeCheckError] [(ExplicitExpression, ExplicitExpression)] +checkAssignment _ [] = Right [] +checkAssignment symbs ((assign, ex): assigns) = + case checkExpression (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 + Left err -> Left [err] + Right checkedA -> case checkAssignment symbs assigns of + Left err -> Left err + Right checked -> Right $ (checkedA, checkedExp) : checked \ No newline at end of file diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index f896f04..a69aa54 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -16,6 +16,7 @@ data TypeCheckError = | CardinalityMismatch Cardinality Cardinality | MultipleDeclarations String | TypeNameReserved String + | UnsupportedExpressionInPathExpression String deriving (Show) -- |Checks whether a data type is valid @@ -46,17 +47,63 @@ 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 checkAttributeType _ (MakeType "int" _ _ _ _) = Right $ BasicType "Integer" checkAttributeType _ (MakeType "string" _ _ _ _) = Right $ BasicType "String" checkAttributeType _ (MakeType "number" _ _ _ _) = Right $ BasicType "Double" checkAttributeType _ (MakeType "boolean" _ _ _ _) = Right $ BasicType "Bool" checkAttributeType _ (MakeType "time" _ _ _ _) = Right $ BasicType "Time" -checkAttributeType definedTypes name - | name `elem` definedTypes = Right name - | otherwise = Left $ UndefinedType (typeName name) - +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 diff --git a/test/Model/TypeSpec.hs b/test/Model/TypeSpec.hs index da8863b..70d53f9 100644 --- a/test/Model/TypeSpec.hs +++ b/test/Model/TypeSpec.hs @@ -51,16 +51,16 @@ spec = do cards1 :: [Cardinality] cards1 = - [Bounds (0, 20), Bounds (10, 15), Bounds (25, 50), Bounds (15, 16), NoBounds, OneBound 25, OneBound 2, OneBound 1, NoBounds, NoBounds] + [Bounds (0, 20), Bounds (10, 15), Bounds (25, 50), Bounds (15, 16), OneBound 0, OneBound 25, OneBound 2, OneBound 1, OneBound 0, OneBound 0] cards2 :: [Cardinality] cards2 = - [Bounds (2, 4), Bounds (4, 45), OneBound 6, NoBounds, Bounds (2, 5), Bounds (2, 30), OneBound 5, NoBounds, OneBound 5, NoBounds] + [Bounds (2, 4), Bounds (4, 45), OneBound 6, OneBound 0, Bounds (2, 5), Bounds (2, 30), OneBound 5, OneBound 0, OneBound 5, OneBound 0] cardsSum :: [Cardinality] cardsSum = - [Bounds (2, 24), Bounds (14, 60), OneBound 31, OneBound 15, OneBound 2, OneBound 27, OneBound 7, OneBound 1, OneBound 5, NoBounds] + [Bounds (2, 24), Bounds (14, 60), OneBound 31, OneBound 15, OneBound 2, OneBound 27, OneBound 7, OneBound 1, OneBound 5, OneBound 0] smallestCards :: [Cardinality] smallestCards = - [Bounds (0, 20), Bounds (4, 45), OneBound 6, NoBounds, NoBounds, OneBound 2, OneBound 2, NoBounds, NoBounds, NoBounds] \ No newline at end of file + [Bounds (0, 20), Bounds (4, 45), OneBound 6, OneBound 0, OneBound 0, OneBound 2, OneBound 2, OneBound 0, OneBound 0, OneBound 0] \ No newline at end of file diff --git a/test/Parser/ExpressionSpec.hs b/test/Parser/ExpressionSpec.hs index 93a1d22..105284c 100644 --- a/test/Parser/ExpressionSpec.hs +++ b/test/Parser/ExpressionSpec.hs @@ -6,6 +6,7 @@ import Test.Hspec import Test.Hspec.Megaparsec import Text.Megaparsec import Model.Function +import Model.Type import Parser.Expression spec :: Spec @@ -70,10 +71,10 @@ exps = [ Function "Function" [Int "3", InfixExp "+" (Int "3") (Int "2"), Variable "e"], -- 10 IfElse (Function "Function" [InfixExp "+" (Int "2") (Int "3"), Variable "e"]) - (InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (Variable "e->x")))) + (InfixExp "-" (InfixExp "+" (Variable "a") (Variable "b")) (InfixExp "*" (Variable "c") (InfixExp "^" (Variable "d") (PathExpression (Variable "e") (Variable "x"))))) (PrefixExp "not" (PostfixExp "exists" (Variable "a"))), -- 11 - IfSimple (List [Int "1", Function "Function" [Int "3"]]) (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (InfixExp "*" (Int "3") (InfixExp "^" (Variable "a->b") (Variable "c")))), + IfSimple (List [Int "1", Function "Function" [Int "3"]]) (InfixExp "-" (InfixExp "-" (Int "1") (Int "2")) (InfixExp "*" (Int "3") (InfixExp "^" (PathExpression (Variable "a") (Variable "b")) (Variable "c")))), -- 12 InfixExp "or" (Variable "a") (Variable "b") ] diff --git a/test/Parser/TypeSpec.hs b/test/Parser/TypeSpec.hs index 09eceb6..2b83741 100644 --- a/test/Parser/TypeSpec.hs +++ b/test/Parser/TypeSpec.hs @@ -36,42 +36,46 @@ types :: [Type] types = [ MakeType {typeName = "Period", typeDescription = Just "description", - superType = MakeType "Something" (BasicType "Object") Nothing [], - typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), + superType = MakeType "Something" (BasicType "Object") Nothing [] [], + typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1), attributeDescription = Just "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."}, - MakeTypeAttribute {attributeName = "testMany", attributeType = MakeType "TestType" (BasicType "Object") Nothing [], cardinality = OneBound 0, + MakeTypeAttribute {attributeName = "testMany", attributeType = MakeType "TestType" (BasicType "Object") Nothing [] [], cardinality = OneBound 0, attributeDescription = Just "Test many"}, - MakeTypeAttribute {attributeName = "testSome", attributeType = MakeType "TestSomeType" (BasicType "Object") Nothing [], cardinality = OneBound 1, + MakeTypeAttribute {attributeName = "testSome", attributeType = MakeType "TestSomeType" (BasicType "Object") Nothing [] [], cardinality = OneBound 1, attributeDescription = Just "Test some"}, - MakeTypeAttribute {attributeName = "testMaybeOne", attributeType = MakeType "TestZeroOneType" (BasicType "Object") Nothing [], cardinality = Bounds (0, 1), + MakeTypeAttribute {attributeName = "testMaybeOne", attributeType = MakeType "TestZeroOneType" (BasicType "Object") Nothing [] [], cardinality = Bounds (0, 1), attributeDescription = Just "Test zero or one"}, - MakeTypeAttribute {attributeName = "testAll", attributeType = MakeType "Test" (BasicType "Object") Nothing [], cardinality = Bounds (2, 15), - attributeDescription = Just "Test all"}]}, + MakeTypeAttribute {attributeName = "testAll", attributeType = MakeType "Test" (BasicType "Object") Nothing [] [], cardinality = Bounds (2, 15), + attributeDescription = Just "Test all"}], + conditions = []}, MakeType {typeName = "TestType", typeDescription = Nothing, superType = BasicType "Object", - typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), - attributeDescription = Nothing}]}, + typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1), + attributeDescription = Nothing}], + conditions = []}, MakeType {typeName = "TestSomeType", typeDescription = Just "description", superType = BasicType "Object", - typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), - attributeDescription = Just "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."}]}, + typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1), + attributeDescription = Just "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."}], + conditions = []}, MakeType {typeName = "TestZeroOneType", typeDescription = Nothing, - superType = MakeType "Period" (BasicType "Object") Nothing [], - typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [], cardinality = Bounds(1, 1), - attributeDescription = Nothing}]}, + superType = MakeType "Period" (BasicType "Object") Nothing [] [], + typeAttributes = [MakeTypeAttribute {attributeName = "periodMultiplier", attributeType = MakeType "int" (BasicType "Object") Nothing [] [], cardinality = Bounds(1, 1), + attributeDescription = Nothing}], + conditions = []}, - MakeType {typeName = "WrongCardinality", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []}, + MakeType {typeName = "WrongCardinality", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = [], conditions = []}, - MakeType {typeName = "WrongCardinality2", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []}, + MakeType {typeName = "WrongCardinality2", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = [], conditions = []}, - MakeType {typeName = "MissingType", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = []} + MakeType {typeName = "MissingType", superType = BasicType "Object", typeDescription = Just "description", typeAttributes = [], conditions = []} ] \ No newline at end of file