diff --git a/RosettaParser.cabal b/RosettaParser.cabal index 9334cf4..14df146 100644 --- a/RosettaParser.cabal +++ b/RosettaParser.cabal @@ -45,6 +45,7 @@ library Semantic.ExpressionChecker Semantic.FunctionChecker Semantic.TypeChecker + Utils.Utils other-modules: Paths_RosettaParser hs-source-dirs: diff --git a/app/Main.hs b/app/Main.hs index e6ca9a8..3731263 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -21,66 +21,98 @@ import Model.Header import Parser.Header import PrettyPrinter.Header import Data.Tuple (fst, snd) +import Data.Void +import Utils.Utils +import Data.Text (Text) --- :set args resources/testAll.rosetta resources/Generated/testAll.hs +-- :set args resources/Rosetta/test-all.rosetta -- :l 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 - case parse rosettaParser "" (Text.pack rosettaString) of - Left errorBundle -> print (errorBundlePretty errorBundle) - Right objs -> do - writeFile (args !! 1) (printHeader (fst objs) ++ printObjects (definedTypes, definedFunctions) (snd objs)) - where - -- |Adds all the function definitions from the file into the symbol table - definedFunctions = addNewFunctions (definedTypes, defaultMap) (snd objs) - -- |Adds all the new data types into the symbol table - definedTypes = addNewTypes [] (snd 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 + let mainFile = head args + parseResult <- parseWithImport mainFile + let checked = checkObjects parseResult + let headers = fstlst checked + let objects = nestedRights $ sndlst checked + if null $ lefts $ concat $ sndlst checked + then + let input = pairRights checked in + mapM_ generateFile input + else error $ show $ lefts $ concat $ sndlst checked + +{- |Recursively parse a file and all the imports into a list of headers and objects +The first argument is the default directory, second argument is the file name +-} +parseWithImport :: String -> IO [(([Type], [Symbol]), (Header, [RosettaObject]))] +parseWithImport file = + do + plain <- readFile file + case parseFile plain of + Left errorBundle -> error $ errorBundlePretty errorBundle ++ "on file" ++ file + Right (MakeHeader name desc vers imp, objs) -> + do + let files = map ((++) (fileDirectory file) . namespaceToName) imp + imports <- mapM parseWithImport files + 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 + 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]) +parseFile plainText = parse rosettaParser "" (Text.pack plainText) + +-- |Converts a RosettaObject into a plain haskell string +printObject :: RosettaObject -> String +printObject (TypeObject t) = printType t +printObject (FunctionObject f) = printFunction f +printObject (EnumObject e) = printEnum e + +-- |Checks all the objects from a list +checkObjects :: [(([Type], [Symbol]), (Header, [RosettaObject]))] -> [(Header, [Either [TypeCheckError] RosettaObject])] +checkObjects [] = [] +checkObjects (((definedTypes, definedSymbols), (header, objs)) : rest) = (header, checked) : checkObjects rest + where + checked = map (checkObject (definedTypes, definedSymbols)) objs + +-- |Checks the RosettaObject for type errors +checkObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] RosettaObject +-- |Checks the type and attributes of a type +checkObject (definedTypes, _) (TypeObject t) = + case checkType definedTypes t of + Left errors -> Left errors + Right typ -> Right $ TypeObject typ +-- |If an enum parses, it cannot throw an error +checkObject _ (EnumObject e) = Right (EnumObject e) +-- |Checks the function inputs, output and assignment +checkObject (definedTypes, definedFunctions) (FunctionObject fun) = + case checkFunction (definedTypes, defaultMap ++ definedFunctions) fun of + Left errors -> Left errors + 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 + | otherwise = error $ show (fromLeftUnsafe definedFunctions) 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 (TypeObject o: os) = addDefinedTypes (addNewTypes defined os) [o] addNewTypes defined (EnumObject (MakeEnum name _ _): os) = addDefinedTypes (addNewTypes defined os) [MakeType name (BasicType "Object") Nothing []] addNewTypes defined (_ :os) = addNewTypes defined os -- |Parses any supported Rosetta types into a list of RosettaObject rosettaParser :: Parser (Header, [RosettaObject]) -rosettaParser = do +rosettaParser = do header <- headerParser objects <- many (try parseEnum <|> try parseType <|> try parseFunction) <* eof return (header, objects) @@ -89,13 +121,17 @@ rosettaParser = do 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 \ No newline at end of file + FunctionObject <$> functionParser + +-- |Generate a new haskell file based on the rosetta objects and header +generateFile :: (Header, [RosettaObject]) -> IO () +generateFile (header, objects) = writeFile (haskellFileName $ namespace header) (printHeader header ++ concatMap printObject objects) \ No newline at end of file diff --git a/resources/testAll.rosetta b/resources/Rosetta/test-all.rosetta similarity index 68% rename from resources/testAll.rosetta rename to resources/Rosetta/test-all.rosetta index 8721b95..5c5e95b 100644 --- a/resources/testAll.rosetta +++ b/resources/Rosetta/test-all.rosetta @@ -1,16 +1,7 @@ -namespace cdm.main : <"Something"> +namespace test.all : <"Something"> version "${version.ok}" -enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week."> - D displayName "day" <"Day"> - M displayName "month" <"Month"> - Y displayName "year" <"Year"> - -type Period extends TestType: <"description"> - periodMultiplier int (1..1) <"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."> - testMany TestType (0..*) <"Test many"> - testSome TestSomeType (1..*) <"Test some"> - testMaybeOne TestZeroOneType (0..1) <"Test zero or one"> +import test.period.* type TestType: testType int (1..1) diff --git a/resources/Rosetta/test-period.rosetta b/resources/Rosetta/test-period.rosetta new file mode 100644 index 0000000..e745c89 --- /dev/null +++ b/resources/Rosetta/test-period.rosetta @@ -0,0 +1,13 @@ +namespace test.period : <"Something"> +version "${version.ok}" + +enum PeriodEnum: <"The enumerated values to specified the period, e.g. day, week."> + D displayName "day" <"Day"> + M displayName "month" <"Month"> + Y displayName "year" <"Year"> + +type Period: <"description"> + periodMultiplier int (1..1) <"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."> + testMany boolean (0..*) <"Test many"> + testSome boolean (1..*) <"Test some"> + testMaybeOne int (0..1) <"Test zero or one"> diff --git a/src/Model/RosettaObject.hs b/src/Model/RosettaObject.hs index 91d0314..95024e7 100644 --- a/src/Model/RosettaObject.hs +++ b/src/Model/RosettaObject.hs @@ -8,4 +8,5 @@ import Model.Type data RosettaObject = EnumObject EnumType | TypeObject Type - | FunctionObject Function \ No newline at end of file + | FunctionObject Function + deriving Show \ No newline at end of file diff --git a/src/PrettyPrinter/Header.hs b/src/PrettyPrinter/Header.hs index 7f5e401..5c04737 100644 --- a/src/PrettyPrinter/Header.hs +++ b/src/PrettyPrinter/Header.hs @@ -6,31 +6,22 @@ import Model.Header import PrettyPrinter.General import Prettyprinter import Data.Char +import Utils.Utils -- |Converts a Header into a haskell valid String printHeader :: Header -> String printHeader (MakeHeader name (Just description) _ imports) = - show $ vcat ["module" <+> pretty (convertFirst name) <+> "where", + show $ vcat ["module" <+> pretty (removePeriods name) <+> "where", enclose "{-" "-}" (pretty description), emptyDoc, vcat (map printImport imports), emptyDoc] printHeader (MakeHeader name Nothing _ imports) = - show $ vcat ["module" <+> pretty (convertFirst name) <+> "where", + show $ vcat ["module" <+> pretty (removePeriods name) <+> "where", emptyDoc, vcat (map printImport imports), emptyDoc] -- |Converts an import name into an import prettyprinter doc printImport :: String -> Doc a -printImport name = "import" <+> pretty name - -convertName :: String -> String -convertName [] = [] -convertName (c:cs) - | c == '.' = c : convertFirst cs - | otherwise = c : convertName cs - -convertFirst :: String -> String -convertFirst [] = [] -convertFirst (c:cs) = toUpper c : convertName cs \ No newline at end of file +printImport name = "import" <+> pretty (removePeriods name) \ No newline at end of file diff --git a/src/Semantic/TypeChecker.hs b/src/Semantic/TypeChecker.hs index a11a42a..e801191 100644 --- a/src/Semantic/TypeChecker.hs +++ b/src/Semantic/TypeChecker.hs @@ -28,7 +28,7 @@ checkType _ (BasicType b) = Right (BasicType b) populateSuper :: [Type] -> [Type] -> Type -> Either TypeCheckError Type populateSuper _ _ (BasicType "Object") = Right (BasicType "Object") populateSuper _ _ (BasicType _) = Left $ UndefinedType "Can't extend basic types" -populateSuper _ [] t = error "WTF" --Left $ UndefinedType (typeName t) +populateSuper _ [] t = Left $ UndefinedType (typeName t) populateSuper allTypes (currType : types) (MakeType t super d a) | typeName currType == t = case populateSuper allTypes allTypes super of Right superChecked -> Right $ MakeType t superChecked (typeDescription currType) (typeAttributes currType) diff --git a/src/Utils/Utils.hs b/src/Utils/Utils.hs new file mode 100644 index 0000000..52c6b17 --- /dev/null +++ b/src/Utils/Utils.hs @@ -0,0 +1,70 @@ +module Utils.Utils where + +import Data.Either +import Data.Char + +-- |Convert a namespace to a filename +namespaceToName :: String -> String +namespaceToName [] = ".rosetta" +namespaceToName ".*" = ".rosetta" +namespaceToName (c : cs) + | c == '.' = '-' : namespaceToName cs + | otherwise = c : namespaceToName cs + +-- |Returns the directory of a file from a path +fileDirectory :: String -> String +fileDirectory s = take (length s - length (fileName s)) s + +-- |Returns the name of a file from a path +fileName :: String -> String +fileName path = reverse $ fileName1 $ reverse path + +-- |Auxiliary function for the name of a file from a path +fileName1 :: String -> String +fileName1 [] = [] +fileName1 (c : cs) + | c == '/' = [] + | otherwise = c : fileName1 cs + +-- |Create a new haskell filename based on the namespace +haskellFileName :: String -> String +haskellFileName s = "resources/Generated/" ++ removePeriods s ++".hs" + +-- |Function to remove all the periods from a name, and convert the name to CamelCase +removePeriods :: String -> String +removePeriods [] = [] +removePeriods ['*'] = [] +removePeriods (c:cs) = toUpper c : removePeriods1 cs + +-- |Auxiliary function for converting names +removePeriods1 :: String -> String +removePeriods1 [] = [] +removePeriods1 (c:cs) + | c == '.' = removePeriods cs + | otherwise = c : removePeriods1 cs + +-- |Extract the first elements from a list of tuples +fstlst :: [(a, b)] -> [a] +fstlst [] = [] +fstlst ((a,_) : rst) = a : fstlst rst + +-- |Extract the second elements from a list of tuples +sndlst :: [(a, b)] -> [b] +sndlst [] = [] +sndlst ((_, b): rst) = b : sndlst rst + +nestedLefts :: [[Either a b]] -> [[a]] +nestedLefts = map lefts + +nestedRights :: [[Either a b]] -> [[b]] +nestedRights = map rights + +-- |Get the objects from a pair with an either +pairLefts :: [(a, [Either b c])] -> [(a, [b])] +pairLefts [] = [] +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