diff --git a/app/Main.hs b/app/Main.hs index 3731263..5df483f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -33,6 +33,12 @@ main = do args <- getArgs let mainFile = head args parseResult <- parseWithImport mainFile + + --Start + let maps = fstlst parseResult + let funcs = concat $ sndlst maps + print funcs + --END let checked = checkObjects parseResult let headers = fstlst checked let objects = nestedRights $ sndlst checked @@ -59,7 +65,8 @@ parseWithImport file = let importedTypes = concat $ fstlst importedSymbolTable let importedFunctions = concat $ sndlst importedSymbolTable let definedTypes = addNewTypes importedTypes objs - let definedFunctions = addNewFunctions (definedTypes, importedFunctions) objs + let definedFunctions = addNewFunctions (definedTypes, importedFunctions) objs + let _ = last definedFunctions return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports -- |Parse a file into a list of RosettaObjects diff --git a/resources/Rosetta/test-all.rosetta b/resources/Rosetta/test-all.rosetta index 5c5e95b..4243a71 100644 --- a/resources/Rosetta/test-all.rosetta +++ b/resources/Rosetta/test-all.rosetta @@ -36,6 +36,15 @@ func Something: <"asd"> assign-output: if True and False then valuationTime +func Something: <"asd"> + inputs: + equity1 boolean (1..1) + valuationTime ObservationPrimitive (1..1) + output: + valuation ObservationPrimitive (0..*) + + assign-output: if True and False then valuationTime + func SomethingElse: <"dsa"> inputs: valuationTime ObservationPrimitive (1..1) diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index b15c80f..515f074 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -5,12 +5,13 @@ module PrettyPrinter.Type where import Prettyprinter import PrettyPrinter.General import Model.Type +import Utils.Utils -- |Converts an EnumType into a haskell valid String printType :: Type -> String printType (MakeType name (MakeType super _ _ _) description attributes) = printType (MakeType name (BasicType "Object") description (superToAttribute name super:attributes)) printType (MakeType name (BasicType "Object") description attributes) = - show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes attributes), "}", "", emptyDoc]) + show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes name attributes), "}", "", emptyDoc]) printType (MakeType _ (BasicType _) _ _) = error "Can't extend basic types" printType (BasicType name) = show $ pretty name @@ -19,16 +20,16 @@ superToAttribute :: String -> String -> TypeAttribute superToAttribute name typ = MakeTypeAttribute ("super" ++ name) (MakeType typ (BasicType "Object") Nothing []) (Bounds (1, 1)) (Just "Pointer to super class") -- |Converts a list of TypeAttributes into a list of haskell valid Docs -printAttributes :: [TypeAttribute] -> [Doc a] -printAttributes [] = [] -printAttributes [at] = [printAttribute at] -printAttributes (at : ats) = (printAttribute at <> ",") : printAttributes ats +printAttributes :: String -> [TypeAttribute] -> [Doc a] +printAttributes _ [] = [] +printAttributes objName [at] = [printAttribute objName at] +printAttributes objName (at : ats) = (printAttribute objName at <> ",") : printAttributes objName ats -- |Converts a TypeAttribute into a haskell valid Doc -printAttribute :: TypeAttribute -> Doc a -printAttribute (MakeTypeAttribute name typ crd description) = +printAttribute :: String -> TypeAttribute -> Doc a +printAttribute objName (MakeTypeAttribute name typ crd description) = printDescription description - (pretty name <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd description)) + (pretty objName <> pretty (capitalize name) <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd description)) -- |Converts a Cardinality into a haskell valid Doc printCardinality :: TypeAttribute -> Doc a diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index ff7d2ef..b2274e0 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -5,6 +5,7 @@ import Data.Either import Data.Maybe import Model.Type import Semantic.TypeChecker +import Utils.Utils -- |A declared variable or function data Symbol = Var{ @@ -59,7 +60,9 @@ defaultMap = [ -- |Checks whether a function is valid (inputs, outputs are of valid type and all variables are defined) and adds it to the symbol table addFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] [Symbol] addFunction (definedTypes, definedSymbols) (MakeFunction name _ inps out _) - | null (lefts checkedInputs) && isRight checkedOutput = Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput, Model.Type.cardinality out) : definedSymbols + | null (lefts checkedInputs) && isRight checkedOutput = if name `elem` map funcName definedSymbols + then Left [MultipleDeclarations name] + else Right $ Func name (map typeAndCardinality (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput, Model.Type.cardinality out) : definedSymbols | isLeft checkedOutput = Left [fromLeftUnsafe checkedOutput] | otherwise = Left $ lefts checkedInputs where diff --git a/src/Semantic/FunctionChecker.hs b/src/Semantic/FunctionChecker.hs index da3c20f..e1e02e3 100644 --- a/src/Semantic/FunctionChecker.hs +++ b/src/Semantic/FunctionChecker.hs @@ -6,6 +6,7 @@ import Semantic.ExpressionChecker import Semantic.TypeChecker import Data.Either import Data.Char +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] Function @@ -16,7 +17,7 @@ checkFunction (definedTypes, symbols) (MakeFunction name desc inp out ex) Left err -> Left [err] | otherwise = Left $ lefts [checkedOut] ++ lefts checkedIn ++ lefts [checkedEx] where + checkedIn = checkAttributes definedTypes inp localEnv = addVariables symbols inp checkedEx = checkExpression localEnv ex - checkedIn = checkAttributes definedTypes inp checkedOut = head $ checkAttributes definedTypes [out] \ No newline at end of file diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index e801191..8a5bf08 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -2,6 +2,7 @@ module Semantic.TypeChecker where import Model.Type import Data.Either +import Utils.Utils -- |A datatype for the different types of type check errors data TypeCheckError = @@ -13,6 +14,7 @@ data TypeCheckError = | UndefinedVariable String | TypeMismatch String String | CardinalityMismatch Cardinality Cardinality + | MultipleDeclarations String deriving (Show) -- |Checks whether a data type is valid @@ -58,18 +60,6 @@ checkAttributeType definedTypes name addDefinedTypes :: [Type] -> [Type] -> [Type] addDefinedTypes l [] = l addDefinedTypes l (BasicType _ : ts) = addDefinedTypes l ts -addDefinedTypes l (t:ts) = t : addDefinedTypes l ts - --- |Auxiliary function to get the right value from an either that stops with an error if the value is left --- used when it is certain that the value will be right -fromRightUnsafe :: (Show a) => Either a b -> b -fromRightUnsafe x = case x of - Left a -> error ("Value is Left" ++ show a) - Right b -> b - --- |Auxiliary function to get the left value from an either that stops with an error if the value is right --- used when it is certain that the value will be left -fromLeftUnsafe :: Either a b -> a -fromLeftUnsafe x = case x of - Left a -> a - Right _ -> error "Value is Right" \ No newline at end of file +addDefinedTypes l (t:ts) + | typeName t `elem` map typeName l = error $ "Multiple declarations of " ++ show t + | otherwise = t : addDefinedTypes l ts \ No newline at end of file diff --git a/src/Utils/Utils.hs b/src/Utils/Utils.hs index 52c6b17..4db9878 100644 --- a/src/Utils/Utils.hs +++ b/src/Utils/Utils.hs @@ -3,6 +3,11 @@ module Utils.Utils where import Data.Either import Data.Char + +-- |Capitalise a string +capitalize :: String -> String +capitalize s = toUpper (head s) : tail s + -- |Convert a namespace to a filename namespaceToName :: String -> String namespaceToName [] = ".rosetta" @@ -67,4 +72,19 @@ pairLefts ((a, b) : rst) = (a, lefts b) : pairLefts rst -- |Get the objects from a pair with an either pairRights :: [(a, [Either b c])] -> [(a, [c])] pairRights [] = [] -pairRights ((a, c) : rst) = (a, rights c) : pairRights rst \ No newline at end of file +pairRights ((a, c) : rst) = (a, rights c) : pairRights rst + + +-- |Auxiliary function to get the right value from an either that stops with an error if the value is left +-- used when it is certain that the value will be right +fromRightUnsafe :: Either a b -> b +fromRightUnsafe x = case x of + Left a -> error "Value is Left" + Right b -> b + +-- |Auxiliary function to get the left value from an either that stops with an error if the value is right +-- used when it is certain that the value will be left +fromLeftUnsafe :: Either a b -> a +fromLeftUnsafe x = case x of + Left a -> a + Right _ -> error "Value is Right" \ No newline at end of file