diff --git a/app/Main.hs b/app/Main.hs index 5df483f..70bd61f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,19 +26,14 @@ import Utils.Utils import Data.Text (Text) -- :set args resources/Rosetta/test-all.rosetta --- :l resources/Generated/testAll.hs +-- :l resources/Generated/testAll.hs resources/Generated/testPeriod.hs + -- |Reads a rosetta string from the first input argument and writes a haskell output to the file given as a second argument main :: IO () 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 @@ -64,10 +59,12 @@ parseWithImport file = let importedSymbolTable = fstlst (concat imports) let importedTypes = concat $ fstlst importedSymbolTable let importedFunctions = concat $ sndlst importedSymbolTable - let definedTypes = addNewTypes importedTypes objs - let definedFunctions = addNewFunctions (definedTypes, importedFunctions) objs - let _ = last definedFunctions - return $ ((definedTypes, definedFunctions), (MakeHeader name desc vers imp, objs)) : concat imports + case addNewTypes importedTypes objs 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 -- |Parse a file into a list of RosettaObjects parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject]) @@ -102,19 +99,22 @@ checkObject (definedTypes, definedFunctions) (FunctionObject fun) = Right func -> Right $ FunctionObject func -- |Adds new defined functions into the symbol table -addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> [Symbol] -addNewFunctions (_, s) [] = s -addNewFunctions (t, s) ((FunctionObject f):os) - | isRight definedFunctions = fromRightUnsafe definedFunctions - | otherwise = error $ show (fromLeftUnsafe definedFunctions) - where definedFunctions = addFunction (t, addNewFunctions (t, s) os) f +addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> Either [TypeCheckError] [Symbol] +addNewFunctions (_, s) [] = Right [] +addNewFunctions (t, s) ((FunctionObject f):os) = + case addNewFunctions (t, s) os of + Left errors -> Left errors + Right symbs -> addFunction (t, symbs) f addNewFunctions (t, s) (_:os) = addNewFunctions (t, s) os -- |Adds new defined types into the symbol table -addNewTypes :: [Type] -> [RosettaObject] -> [Type] -addNewTypes l [] = l -addNewTypes defined (TypeObject o: os) = addDefinedTypes (addNewTypes defined os) [o] -addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addDefinedTypes (addNewTypes defined os) [MakeType name (BasicType "Object") Nothing []] +addNewTypes :: [Type] -> [RosettaObject] -> Either [TypeCheckError] [Type] +addNewTypes l [] = Right l +addNewTypes defined (TypeObject o: os) = + case addNewTypes defined os of + Left errors -> Left errors + Right types -> addDefinedTypes types [o] +addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addNewTypes defined (TypeObject (MakeType name (BasicType "Object") Nothing []) : os) addNewTypes defined (_ :os) = addNewTypes defined os -- |Parses any supported Rosetta types into a list of RosettaObject diff --git a/resources/Rosetta/test-all.rosetta b/resources/Rosetta/test-all.rosetta index 4243a71..5c5e95b 100644 --- a/resources/Rosetta/test-all.rosetta +++ b/resources/Rosetta/test-all.rosetta @@ -36,15 +36,6 @@ 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/Model/Type.hs b/src/Model/Type.hs index b52b4c2..dbc465b 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -1,7 +1,5 @@ module Model.Type where -import Data.Time.LocalTime() - -- |The representation of a Rosetta data type data Type = MakeType { typeName :: String, diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index 515f074..103ad54 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -29,7 +29,7 @@ printAttributes objName (at : ats) = (printAttribute objName at <> ",") : printA printAttribute :: String -> TypeAttribute -> Doc a printAttribute objName (MakeTypeAttribute name typ crd description) = printDescription description - (pretty objName <> pretty (capitalize name) <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd description)) + (pretty (uncapitalize 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 b2274e0..af3f7dc 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -18,6 +18,15 @@ data Symbol = Var{ argsType :: [(Type, Cardinality)], returnType :: (Type, Cardinality) } deriving (Show) + +instance Eq Symbol where + (==) (Var name1 _ _) (Var name2 _ _) + | name1 == name2 = True + | otherwise = False + (==) (Func name1 _ _) (Func name2 _ _) + | name1 == name2 = True + | otherwise = False + (==) _ _ = False -- |A map of the predefined functions, their arguments and their return type diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index 8a5bf08..d4ca535 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -15,6 +15,7 @@ data TypeCheckError = | TypeMismatch String String | CardinalityMismatch Cardinality Cardinality | MultipleDeclarations String + | TypeNameReserved String deriving (Show) -- |Checks whether a data type is valid @@ -57,9 +58,12 @@ checkAttributeType definedTypes name | otherwise = Left $ UndefinedType (typeName name) -- |Add a list of defined types to the symbol table -addDefinedTypes :: [Type] -> [Type] -> [Type] -addDefinedTypes l [] = l -addDefinedTypes l (BasicType _ : ts) = addDefinedTypes l ts -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 +addDefinedTypes :: [Type] -> [Type] -> Either [TypeCheckError] [Type] +addDefinedTypes l [] = Right l +addDefinedTypes l (BasicType t : ts) = Left [TypeNameReserved t] +addDefinedTypes l (t:ts) = + case addDefinedTypes l ts of + Left error -> Left error + Right types -> if typeName t `elem` map typeName l + then Left [MultipleDeclarations $ show t] + else Right $ t : types \ No newline at end of file diff --git a/src/Utils/Utils.hs b/src/Utils/Utils.hs index 4db9878..b1d5180 100644 --- a/src/Utils/Utils.hs +++ b/src/Utils/Utils.hs @@ -4,10 +4,14 @@ import Data.Either import Data.Char --- |Capitalise a string +-- |Capitalize a string capitalize :: String -> String capitalize s = toUpper (head s) : tail s +-- |Uncapitalize a string +uncapitalize :: String -> String +uncapitalize s = toLower (head s) : tail s + -- |Convert a namespace to a filename namespaceToName :: String -> String namespaceToName [] = ".rosetta" @@ -75,6 +79,13 @@ pairRights [] = [] pairRights ((a, c) : rst) = (a, rights c) : pairRights rst +-- |Check a list for duplicate values. Returns a list with all the values which have duplicates +checkDuplicates :: Eq a => [a] -> [a] +checkDuplicates [] = [] +checkDuplicates (a : as) + | a `elem` as = a : checkDuplicates as + | otherwise = checkDuplicates as + -- |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