diff --git a/app/Main.hs b/app/Main.hs index c18fa35..bd96b90 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,43 +13,53 @@ import PrettyPrinter.Function import Semantic.TypeChecker import Semantic.ExpressionChecker import Semantic.FunctionChecker -import Model.Function import Model.Type import System.Environment.Blank (getArgs) import Model.Enum import Data.Either -- :set args resources/testAll.rosetta resources/Generated/testAll.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 rosettaString <- readFile $ head args + -- |Parse the string read from the input file case parse rosettaParser "" (Text.pack rosettaString) of Left errorBundle -> print (errorBundlePretty errorBundle) Right objs -> do + -- |Write the haskell string into the second argument writeFile (args !! 1) (printObjects (definedTypes, definedFunctions) objs) where + -- |Adds all the function definitions from the file into the symbol table definedFunctions = addNewFunctions (definedTypes, defaultMap) objs + -- |Adds all the new data types into the symbol table definedTypes = addNewTypes [] objs - + +-- |Reads a rosetta string from the first input argument, parses that string and then writes a haskell output to the file given as a second argument printObjects :: ([Type], [Symbol]) -> [RosettaObject] -> String printObjects (t, s) objs | null (lefts finalString) = concat $ rights finalString | otherwise = error $ show $ lefts finalString where finalString = map (printObject (t, s)) objs - + +-- |Checks the RosettaObject for type errors and then converts it into a haskell string printObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] String +-- |Checks the type and attributes of a type and then converts it printObject (definedTypes, _) (TypeObject t) | isRight checked = Right $ printType $ fromRightUnsafe checked | otherwise = Left $ fromLeftUnsafe checked where checked = checkType definedTypes t +-- |Enum is converted directly since no type checks are necessary printObject _ (EnumObject e) = Right $ printEnum e +-- |Checks the function inputs, output and assignment and converts it printObject (definedTypes, definedFunctions) (FunctionObject fun) | isRight checked = Right $ printFunction $ fromRightUnsafe checked | otherwise = Left $ fromLeftUnsafe checked where checked = checkFunction (definedTypes, definedFunctions) fun +-- |Adds new defined functions into the symbol table addNewFunctions :: ([Type], [Symbol]) -> [RosettaObject] -> [Symbol] addNewFunctions (_, s) [] = s addNewFunctions (t, s) ((FunctionObject f):os) @@ -58,65 +68,28 @@ addNewFunctions (t, s) ((FunctionObject f):os) where definedFunctions = addFunction (t, addNewFunctions (t, s) os) 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 Nothing Nothing []] addNewTypes defined (_ :os) = addNewTypes defined os +-- |Parses any supported Rosetta types into a list of RosettaObject rosettaParser :: Parser [RosettaObject] rosettaParser = many (try parseEnum <|> try parseType <|> try parseFunction) <* eof +-- |Reads an enum into a RosettaObject parseEnum :: Parser RosettaObject parseEnum = do EnumObject <$> enumParser +-- |Parse a type into a RosettaObject parseType :: Parser RosettaObject parseType = do TypeObject <$> typeParser +-- |Parse a function into a RosettaObject parseFunction :: Parser RosettaObject parseFunction = do - FunctionObject <$> functionParser - -testEnum :: IO() -testEnum = do - rosettaString <- readFile "resources/Enums/testEnum1.rosetta" - case parse enumParser "" (Text.pack rosettaString) of - Left errorBundle -> print errorBundle - Right enum -> - do - putStrLn $ printEnum enum - writeFile "resources/Generated/generatedEnum.hs" (printEnum enum) - -testTypeParser :: IO() -testTypeParser = do - rosettaString <- readFile "resources/Types/testType1.rosetta" - case parse typeParser "" (Text.pack rosettaString) of - Left errorBundle -> print (errorBundlePretty errorBundle) - Right typ -> - do - putStrLn $ printType typ - print typ - writeFile "resources/Generated/generatedType.hs" (printType typ) - -testTypeChecker :: IO () -testTypeChecker = do - rosettaString <- readFile "src/TestFiles/testType.rosetta" - case parse (many typeParser) "" (Text.pack rosettaString) of - Left errorBundle -> print (errorBundlePretty errorBundle) - Right typ -> - do - print $ map (checkAttributes definedTypes . typeAttributes) typ - where definedTypes = addDefinedTypes [] typ - -testFunc :: IO() -testFunc = do - rosettaString <- readFile "resources/testFunction.rosetta" - case parse functionParser "" (Text.pack rosettaString) of - Left errorBundle -> print (errorBundlePretty errorBundle) - Right fun -> - do - print $ printFunctionSignature fun - print (assignment fun) - writeFile "resources/Generated/generatedFunction.hs" (show $ printFunctionSignature fun) \ No newline at end of file + FunctionObject <$> functionParser \ No newline at end of file diff --git a/src/Model/Enum.hs b/src/Model/Enum.hs index beb3463..e901e0a 100644 --- a/src/Model/Enum.hs +++ b/src/Model/Enum.hs @@ -1,11 +1,13 @@ module Model.Enum where +-- |The representation of a Rosetta enum data type data EnumType = MakeEnum { enumName :: String, enumDescription :: Maybe String, enumValues :: [EnumValue] } deriving (Show, Eq) +-- |The representation of a Rosetta enum value type data EnumValue = MakeEnumValue { enumValueName :: String, enumValueDescription :: Maybe String, diff --git a/src/Model/Function.hs b/src/Model/Function.hs index fdcb9b2..1884bc5 100644 --- a/src/Model/Function.hs +++ b/src/Model/Function.hs @@ -2,6 +2,7 @@ module Model.Function where import Model.Type (TypeAttribute) +-- |The representation of a Rosetta function type data Function = MakeFunction { functionName :: String, @@ -11,18 +12,8 @@ data Function = assignment :: Expression } deriving (Show) - ---data Condition = --- MakeCondition { --- conditionDescription :: Maybe String, --- conditionStatement :: Expression --- } --- | MakePostCondition { --- conditionDescription :: Maybe String, --- conditionStatement :: Expression --- } --- deriving (Show) +-- |The representation of an expression data Expression = Variable String | Int String | Real String diff --git a/src/Model/RosettaObject.hs b/src/Model/RosettaObject.hs index 8a8e315..91d0314 100644 --- a/src/Model/RosettaObject.hs +++ b/src/Model/RosettaObject.hs @@ -4,6 +4,7 @@ import Model.Enum import Model.Function import Model.Type +-- |Any supported Rosetta object data RosettaObject = EnumObject EnumType | TypeObject Type diff --git a/src/Model/Type.hs b/src/Model/Type.hs index 20d1abe..ce9d8da 100644 --- a/src/Model/Type.hs +++ b/src/Model/Type.hs @@ -2,6 +2,7 @@ module Model.Type where import Data.Time.LocalTime() +-- |The representation of a Rosetta data type data Type = MakeType { typeName :: String, superType :: Maybe Type, @@ -22,6 +23,8 @@ instance Eq Type where | otherwise = False (==) _ _ = False + +-- |The representation of an attribute of a data type data TypeAttribute = MakeTypeAttribute { attributeName :: String, attributeType :: Type, @@ -29,7 +32,12 @@ data TypeAttribute = MakeTypeAttribute { attributeDescription :: Maybe String } deriving (Show) -data Cardinality = Bounds (Integer, Integer) +-- |The representation of cardinality +data Cardinality = + -- |The cardinality between two bounds (ex. 2 - 5) + Bounds (Integer, Integer) + -- |The cardinality starting from one bound until infinity (ex. 5 - *) | OneBound Integer + -- |The cardinality of no bounds (ex. * - *) | NoBounds deriving Show \ No newline at end of file diff --git a/src/Parser/Enum.hs b/src/Parser/Enum.hs index bb391d9..1549c62 100755 --- a/src/Parser/Enum.hs +++ b/src/Parser/Enum.hs @@ -7,6 +7,8 @@ import Text.Megaparsec.Char import Text.Megaparsec import Model.Enum + +-- |Parses a complete Rosetta enum into a EnumType enumParser :: Parser EnumType enumParser = do @@ -15,6 +17,8 @@ enumParser = values <- some enumValueParser return (MakeEnum eName eDescription values) + +-- |Parses a Rosetta enum value into a EnumValue enumValueParser :: Parser EnumValue enumValueParser = do @@ -23,6 +27,8 @@ enumValueParser = vDescription <- optional descriptionParser return (MakeEnumValue vName vDescription dName) + +-- |Parses the display name of a Rosetta enum value into a String enumValueDisplayNameParser :: Parser String enumValueDisplayNameParser = do @@ -30,6 +36,8 @@ enumValueDisplayNameParser = _ <- char '"' lexeme $ anySingle `manyTill` char '"' + +-- |Parses the name of a Rosetta enum into a String enumNameParser :: Parser String enumNameParser = do diff --git a/src/Parser/Expression.hs b/src/Parser/Expression.hs index 8e0c5c2..60ada40 100644 --- a/src/Parser/Expression.hs +++ b/src/Parser/Expression.hs @@ -8,6 +8,8 @@ import qualified Data.Text as Text import Text.Megaparsec import Text.Megaparsec.Char + +-- |Parses a complete Rosetta expression into an Expression type expressionParser :: Parser Expression expressionParser = choice [ ifParser, @@ -18,6 +20,7 @@ expressionParser = -- Command Structures ---------------------- -------------------------------------------- +-- |Parses a function call in Rosetta into an Expression functionCallParser :: Parser Expression functionCallParser = do @@ -30,6 +33,7 @@ functionCallParser = Nothing -> return $ Function f [] Just at -> return $ Function f (ats ++ [at]) +-- |Parses an if statement in Rosetta into an Expression ifParser :: Parser Expression ifParser = do @@ -42,6 +46,7 @@ ifParser = 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 ')') @@ -49,6 +54,7 @@ parens = between (char '(') (char ')') -- Terminals ------------------------------- -------------------------------------------- +-- |Parses a list in Rosetta into an Expression listParser :: Parser Expression listParser = do @@ -58,6 +64,7 @@ listParser = _ <- lexeme $ char ']' return $ List (expressions ++ [lastExpr]) +-- |Parses a variable in Rosetta into an Expression variableParser :: Parser Expression variableParser = do @@ -65,18 +72,21 @@ variableParser = 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 +-- |Parses an integer in Rosetta into an Expression integerParser :: Parser Expression integerParser = do nr <- lexeme $ some digitChar return $ Int nr - + +-- |Parses a real number in Rosetta into an Expression decimalParser :: Parser Expression decimalParser = do @@ -84,19 +94,22 @@ decimalParser = _ <- char '.' real <- lexeme $ many digitChar return $ Real $ nr ++ "." ++ real - + +-- |Parses a boolean in Rosetta into an Expression booleanParser :: Parser Expression booleanParser = do bol <- lexeme (string "True" <|> string "False") return $ Boolean $ Text.unpack bol +-- |Parses the empty statement in Rosetta into an Expression emptyParser :: Parser Expression emptyParser = do _ <- lexeme $ string "empty" return Empty +-- |Parses any of the terminal statements in Rosetta into an Expression terminalParser :: Parser Expression terminalParser = do @@ -115,12 +128,18 @@ terminalParser = -- Expressions ----------------------------- -------------------------------------------- +-- |Parses an prefix function statement in Rosetta into an Expression prefixParser :: Parser Expression prefixParser = do op <- lexeme $ choice $ fmap (try . string . Text.pack) prefixOperators PrefixExp (Text.unpack op) <$> expressionParser + +-- |List of prefix operators +prefixOperators :: [String] +prefixOperators = ["-", "not"] +-- |Parses an equality statement in Rosetta into an Expression eqParser :: Parser Expression eqParser = do @@ -130,9 +149,11 @@ eqParser = Left _ -> return s Right o -> eqParser >>= \ex -> return $ InfixExp (Text.unpack o) s ex +-- |The list of equality statements in Rosetta eqFunctions :: [String] eqFunctions = ["=", "<", "<=", ">", ">=", "<>", "all =", "all <>", "any =", "any <>"] +-- |Parses a sum statement in Rosetta into an Expression sumParser :: Parser Expression sumParser = do @@ -142,6 +163,7 @@ sumParser = Left _ -> return f Right o -> sumParser >>= \ex -> return $ reverseExpression $ InfixExp [o] f ex +-- |Parses a multiplication or division statement in Rosetta into an Expression factorParser :: Parser Expression factorParser = do @@ -151,6 +173,7 @@ factorParser = 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 @@ -160,6 +183,7 @@ boolOpParser = 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 = do @@ -168,7 +192,8 @@ powerParser = case op of Left _ -> return p Right _ -> powerParser >>= \ex -> return $ InfixExp "^" p ex - + +-- |Parses a postfix function in Rosetta into an Expression postfixParser :: Parser Expression postfixParser = do @@ -178,6 +203,7 @@ postfixParser = Left _ -> return t Right o -> return $ PostfixExp (Text.unpack o) t +-- |The list of existing postfix Rosetta functions postfixFunctions :: [String] postfixFunctions = ["exists", "is absent", "count", "only-element", "single exists", "multiple exists"] @@ -185,12 +211,15 @@ postfixFunctions = ["exists", "is absent", "count", "only-element", "single exis -- Auxiliary ------------------------------ -------------------------------------------- +-- |Reverses the order of operations for left-associative functions 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 e = e + +-- |The precedence of existing infix functions (higher goes first) precedence :: String -> Int precedence "or" = 1 precedence "and" = 10 @@ -199,7 +228,4 @@ precedence "-" = 2 precedence "*" = 3 precedence "/" = 3 precedence "^" = 4 -precedence _ = 100 - -prefixOperators :: [String] -prefixOperators = ["-", "not"] \ No newline at end of file +precedence _ = 100 \ No newline at end of file diff --git a/src/Parser/Function.hs b/src/Parser/Function.hs index 30f26bd..557a03f 100644 --- a/src/Parser/Function.hs +++ b/src/Parser/Function.hs @@ -10,6 +10,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import Parser.General +-- |Parses a function statement in Rosetta into a Function functionParser :: Parser Function functionParser = do @@ -21,6 +22,7 @@ functionParser = fOutput <- outputAttributeParser MakeFunction fName fDescription fInput fOutput <$> assignmentParser +-- |Parses the output assignment statement from a function in Rosetta into an Expression assignmentParser :: Parser Expression assignmentParser = do @@ -28,18 +30,21 @@ assignmentParser = _ <- lexeme $ char ':' expressionParser +-- |Parses the input attributes from a function statement in Rosetta into a list of TypeAttributes inputAttributesParser :: Parser [TypeAttribute] inputAttributesParser = do _ <- lexeme $ string "inputs:" many $ try attributeParser +-- |Parses the output attribute of a function statement in Rosetta into a TypeAttribute outputAttributeParser :: Parser TypeAttribute outputAttributeParser = do _ <- lexeme $ string "output:" attributeParser +-- |Auxiliary function that parses an attribute into a TypeAttribute attributeParser :: Parser TypeAttribute attributeParser = do diff --git a/src/Parser/General.hs b/src/Parser/General.hs index 481fcc4..ee32f36 100755 --- a/src/Parser/General.hs +++ b/src/Parser/General.hs @@ -10,19 +10,22 @@ import Data.Text type Parser = Parsec Void Text +-- |Auxiliary parser that eliminates trailing white space spaceConsumer :: Parser () spaceConsumer = L.space space1 (L.skipLineComment "//") (L.skipBlockComment "/*" "*/") +-- |Auxiliary parser that runs a parser and eliminates trailing white space lexeme :: Parser a -> Parser a lexeme = L.lexeme spaceConsumer +-- |Parses a description in Rosetta into a String descriptionParser :: Parser String descriptionParser = do _ <- string "<\"" lexeme $ anySingle `manyTill` string "\">" - +-- |Parses a pascal case name into a String (PascalCase) pascalNameParser :: Parser String pascalNameParser = do @@ -30,6 +33,7 @@ pascalNameParser = rest <- lexeme $ many allowedChars if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name") +-- |Parses a camel case name into a String (camelCase) camelNameParser :: Parser String camelNameParser = do @@ -37,6 +41,7 @@ camelNameParser = rest <- lexeme $ many allowedChars if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name") +-- |Parses any name that starts with a letter or '_' into a String nameParser :: Parser String nameParser = do @@ -44,9 +49,12 @@ nameParser = rest <- lexeme $ many allowedChars if first:rest `notElem` restrictedNames then return (first:rest) else fail ((first:rest) ++ " is a restricted name") +-- |Parses a character allowed in names in Rosetta into a Char allowedChars :: Parser Char allowedChars = letterChar <|> digitChar <|> char '_' + +-- |List of restricted names used by Rosetta restrictedNames :: [String] restrictedNames = [ "displayName", diff --git a/src/Parser/Type.hs b/src/Parser/Type.hs index 67d8edc..e339d80 100644 --- a/src/Parser/Type.hs +++ b/src/Parser/Type.hs @@ -7,6 +7,7 @@ import Text.Megaparsec.Char import Text.Megaparsec import Parser.General +-- |Parses a type declaration statement in Rosetta into an Type typeParser :: Parser Type typeParser = do @@ -17,6 +18,7 @@ typeParser = tAttributes <- many $ try typeAttributeParser return (MakeType tName tSuper tDescription tAttributes) +-- |Parses the super class declaration statement in Rosetta into an Type superTypeParser :: Parser Type superTypeParser = do @@ -24,6 +26,7 @@ superTypeParser = name <- pascalNameParser return $ MakeType name Nothing Nothing [] +-- |Parses a declared type attribute in Rosetta into a TypeAttribute typeAttributeParser :: Parser TypeAttribute typeAttributeParser = do @@ -33,11 +36,13 @@ typeAttributeParser = desc <- optional descriptionParser return (MakeTypeAttribute aName (MakeType aType Nothing Nothing []) card desc) +-- |Parses the cardinality of a type attribute in Rosetta into a Cardinality cardinalityParser :: Parser Cardinality cardinalityParser = do try parseBounded <|> try parseSemiBounded <|> try parseUnbounded +-- |Parses a bounded cardinality statement in Rosetta into a Cardinality parseBounded :: Parser Cardinality parseBounded = do @@ -48,7 +53,7 @@ parseBounded = _ <- lexeme $ char ')' return $ Bounds (read low, read up) - +-- |Parses a one bounded cardinality statement in Rosetta into a Cardinality parseSemiBounded :: Parser Cardinality parseSemiBounded = do @@ -57,13 +62,14 @@ parseSemiBounded = _ <- lexeme $ string "..*)" return $ OneBound $ read low - +-- |Parses an unbounded cardinality statement in Rosetta into a Cardinality parseUnbounded :: Parser Cardinality parseUnbounded = do _ <- lexeme $ string "(*..*)" return NoBounds +-- |Parses the name of a type in Rosetta into a String typeNameParser :: Parser String typeNameParser = do diff --git a/src/PrettyPrinter/Enum.hs b/src/PrettyPrinter/Enum.hs index 2490000..e14c6a9 100644 --- a/src/PrettyPrinter/Enum.hs +++ b/src/PrettyPrinter/Enum.hs @@ -6,6 +6,7 @@ import Model.Enum import PrettyPrinter.General import Prettyprinter +-- |Converts an EnumType into a haskell valid String printEnum :: EnumType -> String printEnum (MakeEnum name description values) = show $ printDescription description @@ -14,22 +15,27 @@ printEnum (MakeEnum name description values) = "", printDisplayNames name values]) +-- |Converts a list of EnumValues into a haskell valid Doc printEnumValues :: [EnumValue] -> Doc a printEnumValues [] = "" printEnumValues (x:xs) = vcat (printFirstEnumValue x: map printEnumValue xs) +-- |Converts the first EnumValue (in haskell without the '|') into a haskell valid Doc printFirstEnumValue :: EnumValue -> Doc a printFirstEnumValue (MakeEnumValue name description _) = printDescription description (pretty name) +-- |Converts a non-first EnumValue (in haskell with the '|') into a haskell valid Doc printEnumValue :: EnumValue -> Doc a printEnumValue (MakeEnumValue name description _) = printDescription description ("|" <+> pretty name) +-- |Converts the display names of an EnumType into a haskell valid Doc printDisplayNames :: String -> [EnumValue] -> Doc a printDisplayNames name values = nest 4 $ vcat ("instance Show" <+> pretty name <+> "where": map printDisplayName values) +-- |Converts a single display name into a haskell valid Doc printDisplayName :: EnumValue -> Doc a printDisplayName (MakeEnumValue name _ (Just display)) = "show" <+> pretty name <+> "= \"" <> pretty display <> "\"" diff --git a/src/PrettyPrinter/Function.hs b/src/PrettyPrinter/Function.hs index c573600..00a8f5f 100644 --- a/src/PrettyPrinter/Function.hs +++ b/src/PrettyPrinter/Function.hs @@ -9,9 +9,11 @@ import PrettyPrinter.Type -- show printStatementTree +-- |Converts a Function into a haskell valid String printFunction :: Function -> String printFunction f = show $ vcat [printFunctionSignature f, printFunctionBody f] +-- |Converts the body of a Function into a haskell valid Doc printFunctionBody :: Function -> Doc a printFunctionBody (MakeFunction name _ _ _ ex) = pretty name <+> "=" <+> printExpression ex printExpression :: Expression -> Doc a @@ -29,9 +31,11 @@ printExpression (InfixExp name ex1 ex2) = printExpression ex1 <+> pretty name <+ printExpression (IfSimple cond ex) = "if" <+> printExpression cond <+> "then" <+> printExpression ex <+> "else" <+> "pure ()" printExpression (IfElse cond ex1 ex2) = "if" <+> printExpression cond <+> "then" <+> printExpression ex1 <+> "else" <+> printExpression ex2 +-- |Converts a function into a haskell valid Doc representing the signature of the function printFunctionSignature :: Function -> Doc a printFunctionSignature (MakeFunction name description inputs output _) = printDescription description (pretty name <+> prettyPrintType (Prelude.map printCardinality (inputs ++ [output]))) +-- |Zips the signature with the needed characters ('::', '->') prettyPrintType :: [Doc x] -> Doc x prettyPrintType = align . sep . Prelude.zipWith (<+>) ("::" : repeat "->") \ No newline at end of file diff --git a/src/PrettyPrinter/General.hs b/src/PrettyPrinter/General.hs index cfaf8fd..ac9ba6c 100644 --- a/src/PrettyPrinter/General.hs +++ b/src/PrettyPrinter/General.hs @@ -4,6 +4,7 @@ module PrettyPrinter.General where import Prettyprinter +-- |Converts a description String into a haskell valid Doc printDescription :: Maybe String -> Doc a -> Doc a printDescription (Just description) doc = vcat [enclose "{-" "-}" (pretty description), doc] diff --git a/src/PrettyPrinter/RosettaObject.hs b/src/PrettyPrinter/RosettaObject.hs index 82d67a5..e701b56 100644 --- a/src/PrettyPrinter/RosettaObject.hs +++ b/src/PrettyPrinter/RosettaObject.hs @@ -5,6 +5,7 @@ import PrettyPrinter.Enum import PrettyPrinter.Function import PrettyPrinter.Type +-- |Converts a supported Rosetta object into a haskell valid String printRosettaObject :: RosettaObject -> String printRosettaObject (EnumObject a) = printEnum a printRosettaObject (TypeObject a) = printType a diff --git a/src/PrettyPrinter/Type.hs b/src/PrettyPrinter/Type.hs index ee649a6..d10092a 100644 --- a/src/PrettyPrinter/Type.hs +++ b/src/PrettyPrinter/Type.hs @@ -6,6 +6,7 @@ import Prettyprinter import PrettyPrinter.General import Model.Type +-- |Converts an EnumType into a haskell valid String printType :: Type -> String printType (MakeType name (Just (MakeType super _ _ _)) description attributes) = printType (MakeType name Nothing description (superToAttribute super:attributes)) printType (MakeType _ (Just (BasicType _)) _ _) = error "Can't extend basic types" @@ -13,24 +14,23 @@ printType (MakeType name Nothing description attributes) = show $ printDescription description (vcat [nest 4 $ vcat ("data" <+> pretty name <+> "=" <+> "Make" <> pretty name <+> "{": printAttributes attributes), "}", ""]) printType (BasicType name) = show $ pretty name ---printSuperType :: Maybe Type -> Doc a ---printSuperType (Just (MakeType name _ _ _)) = "super" <+> "::" <+> pretty name ---printSuperType (Just (BasicType _)) = error "Can't extend basic types" ---printSuperType Nothing = emptyDoc - +-- |Creates an attribute that accesses the super type superToAttribute :: String -> TypeAttribute superToAttribute name = MakeTypeAttribute "super" (MakeType name Nothing 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 +-- |Converts a TypeAttribute into a haskell valid Doc printAttribute :: TypeAttribute -> Doc a printAttribute (MakeTypeAttribute name typ crd description) = printDescription description (pretty name <+> "::" <+> printCardinality (MakeTypeAttribute name typ crd description)) +-- |Converts a Cardinality into a haskell valid Doc printCardinality :: TypeAttribute -> Doc a printCardinality (MakeTypeAttribute _ typ (Bounds (x, y)) _) | x == 0 && y == 1 = "Maybe" <+> pretty (typeName typ) diff --git a/src/Semantic/ExpressionChecker.hs b/src/Semantic/ExpressionChecker.hs index c828896..c974419 100644 --- a/src/Semantic/ExpressionChecker.hs +++ b/src/Semantic/ExpressionChecker.hs @@ -6,6 +6,7 @@ import Data.Maybe import Model.Type import Semantic.TypeChecker +-- |A declared variable or function data Symbol = Var{ varName :: String, declaredType :: Type @@ -16,6 +17,7 @@ data Symbol = Var{ returnType :: Type } +-- |A map of the predefined functions, their arguments and their return type defaultMap :: [Symbol] defaultMap = [ Func "or" [BasicType "Boolean", BasicType "Boolean"] (BasicType "Boolean"), @@ -52,6 +54,7 @@ defaultMap = [ Func "count" [BasicType "Any"] (BasicType "Integer") ] +-- |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 attributeType (rights checkedInputs)) (attributeType $ fromRightUnsafe checkedOutput) : allSymbols @@ -62,10 +65,12 @@ addFunction (definedTypes, definedSymbols) (MakeFunction name _ inps out _) checkedOutput = head $ checkAttributes definedTypes [out] allSymbols = addVariables definedSymbols inps +-- |Adds a newly defined variable to the symbol table addVariables :: [Symbol] -> [TypeAttribute] -> [Symbol] addVariables s [] = s addVariables s ((MakeTypeAttribute name typ _ _) : vars) = Var name typ : addVariables s vars +-- |Checks the type of a given expression checkExpression :: [Symbol] -> Expression -> Either TypeCheckError Type checkExpression symbolMap (Variable var) = findVarType var symbolMap checkExpression _ (Int _) = Right $ BasicType "Integer" @@ -78,10 +83,12 @@ checkExpression symbolMap (PrefixExp name ex) = checkFunctionCall symbolMap name 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]) +-- |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) | isRight condType && isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = checkExpression symbolMap ex | otherwise = Left IfConditionNotBoolean where condType = checkExpression symbolMap cond +-- |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) | isRight condType || isRight (typeMatch (fromRightUnsafe condType) (BasicType "Boolean")) = Left IfConditionNotBoolean | isRight ex1Type || isRight ex2Type || isRight (typeMatch (fromRightUnsafe ex1Type) (fromRightUnsafe ex2Type)) = Left IfExpressionsDifferentTypes @@ -90,12 +97,14 @@ checkExpression symbolMap (IfElse cond ex1 ex2) ex1Type = checkExpression symbolMap ex1 ex2Type = checkExpression symbolMap ex2 +-- |Checks that all the expressions in a list have compatible types checkList :: [Symbol] -> [Expression] -> Either TypeCheckError Type checkList symbs exps | isRight typ && fromRightUnsafe typ == BasicType "Any" = Right $ BasicType "Empty" | otherwise = typ where typ = checkList1 symbs exps (BasicType "Any") +-- |Auxiliary function for the check list function checkList1 :: [Symbol] -> [Expression] -> Type -> Either TypeCheckError Type checkList1 _ [] typ = Right typ checkList1 symbs (ex : exps) typ @@ -106,6 +115,7 @@ checkList1 symbs (ex : exps) typ exTyp = checkExpression symbs ex match = typeMatch typ (fromRightUnsafe exTyp) +-- |Checks whether the function that is called is already defined with the same argument types checkFunctionCall :: [Symbol] -> String -> [Either TypeCheckError Type] -> Either TypeCheckError Type checkFunctionCall [] fun args = Left $ UndefinedFunction $ "Undefined function: \"" ++ fun ++ "\" [" ++ concatMap typeName (rights args) ++ "]" checkFunctionCall ((Func n a r):symbolMap) name args @@ -116,6 +126,7 @@ checkFunctionCall ((Func n a r):symbolMap) name args checkFunctionCall (_:symbolMap) name args = checkFunctionCall symbolMap name args --Try to match 2nd type to first type +-- |Checks whether two types are compatible typeMatch :: Type -> Type -> Either TypeCheckError Type typeMatch (BasicType "Any") x = Right x typeMatch (BasicType "Double") (BasicType "Integer") = Right $ BasicType "Dobule" @@ -127,6 +138,7 @@ typeMatch s s2 | isJust $ superType s2 = typeMatch s (fromJust $ superType s2) | otherwise = Left $ TypeMismatch (typeName s) (typeName s2) +-- |Looks in the symbol map for the type of a variable findVarType :: String -> [Symbol] -> Either TypeCheckError Type findVarType var [] = Left $ UndefinedVariable var findVarType x ((Var name typ):symbols) diff --git a/src/Semantic/FunctionChecker.hs b/src/Semantic/FunctionChecker.hs index c8e1134..d87bfab 100644 --- a/src/Semantic/FunctionChecker.hs +++ b/src/Semantic/FunctionChecker.hs @@ -6,6 +6,7 @@ import Semantic.ExpressionChecker import Semantic.TypeChecker import Data.Either +-- |Checks if all the inputs and the out of a function call have valid types, and then checks that the assign-output expression is valid checkFunction :: ([Type], [Symbol]) -> Function -> Either [TypeCheckError] Function checkFunction (definedTypes, definedFunctions) (MakeFunction name desc inp out ex) | isRight checkedEx && isRight checkedOut && null (lefts checkedIn) = Right $ MakeFunction name desc (rights checkedIn) (fromRightUnsafe checkedOut) ex diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index 9e07bac..21b9b4b 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -3,6 +3,7 @@ module Semantic.TypeChecker where import Model.Type import Data.Either +-- |A datatype for the different types of type check errors data TypeCheckError = UndefinedType String | IfConditionNotBoolean @@ -13,6 +14,7 @@ data TypeCheckError = | TypeMismatch String String deriving (Show) +-- |Checks whether a data type is valid checkType :: [Type] -> Type -> Either [TypeCheckError] Type checkType definedTypes (MakeType name super desc attr) | null (lefts checkedAttr) = Right $ MakeType name super desc (rights checkedAttr) @@ -20,6 +22,8 @@ checkType definedTypes (MakeType name super desc attr) where checkedAttr = checkAttributes definedTypes attr checkType _ (BasicType b) = Right (BasicType b) + +-- |Checks whether all the types of the attributes of a data type are already defined checkAttributes :: [Type] -> [TypeAttribute] -> [Either TypeCheckError TypeAttribute] checkAttributes _ [] = [] checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) @@ -27,6 +31,7 @@ checkAttributes definedTypes ((MakeTypeAttribute name typ crd desc):as) | otherwise = Left (fromLeftUnsafe checked) : checkAttributes definedTypes as where checked = checkAttributeType definedTypes typ +-- |Checks whether a type is predefined or in the symbol table checkAttributeType :: [Type] -> Type -> Either TypeCheckError Type checkAttributeType _ (MakeType "int" _ _ _) = Right $ BasicType "Integer" checkAttributeType _ (MakeType "string" _ _ _) = Right $ BasicType "String" @@ -37,16 +42,21 @@ checkAttributeType definedTypes name | name `elem` definedTypes = Right 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) = 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