Added support for multiple namespaces and imports

RosettaParser.cabal

@@ -45,6 +45,7 @@ library
       Semantic.ExpressionChecker
       Semantic.FunctionChecker
       Semantic.TypeChecker
+      Utils.Utils
   other-modules:
       Paths_RosettaParser
   hs-source-dirs:

app/Main.hs

@@ -21,53 +21,85 @@ 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
+    let mainFile = head args
-    case parse rosettaParser "" (Text.pack rosettaString) of
+    parseResult <- parseWithImport mainFile
-        Left errorBundle -> print (errorBundlePretty errorBundle)
+    let checked = checkObjects parseResult
-        Right objs -> do
+    let headers = fstlst checked
-            writeFile (args !! 1) (printHeader (fst objs) ++ printObjects (definedTypes, definedFunctions) (snd objs)) 
+    let objects = nestedRights $ sndlst checked
-            where 
+    if null $ lefts $ concat $ sndlst checked
-                -- |Adds all the function definitions from the file into the symbol table
+        then
-                definedFunctions = addNewFunctions (definedTypes, defaultMap) (snd objs)
+            let input = pairRights checked in
-                -- |Adds all the new data types into the symbol table 
+                mapM_ generateFile input
-                definedTypes = addNewTypes [] (snd objs)
+        else error $ show $ lefts $ concat $ sndlst checked
 
--- |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   
+{- |Recursively parse a file and all the imports into a list of headers and objects
-printObjects :: ([Type], [Symbol]) -> [RosettaObject] -> String
+The first argument is the default directory, second argument is the file name
-printObjects (t, s) objs
+-}
-    | null (lefts finalString) = concat $ rights finalString
+parseWithImport :: String -> IO [(([Type], [Symbol]), (Header, [RosettaObject]))]
-    | otherwise = error $ show $ lefts finalString
+parseWithImport file =
-    where finalString = map (printObject (t, s)) objs  
+    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
 
--- |Checks the RosettaObject for type errors and then converts it into a haskell string         
+-- |Parse a file into a list of RosettaObjects
-printObject :: ([Type], [Symbol]) -> RosettaObject -> Either [TypeCheckError] String
+parseFile :: String -> Either (ParseErrorBundle Text Void) (Header, [RosettaObject])
--- |Checks the type and attributes of a type and then converts it
+parseFile plainText = parse rosettaParser "" (Text.pack plainText)
-printObject (definedTypes, _) (TypeObject t)
+
-    | isRight checked = Right $ printType $ fromRightUnsafe checked
+-- |Converts a RosettaObject into a plain haskell string
-    | otherwise = Left $ fromLeftUnsafe checked
+printObject :: RosettaObject -> String
-    where checked = checkType definedTypes t
+printObject (TypeObject t) = printType t
--- |Enum is converted directly since no type checks are necessary
+printObject (FunctionObject f) = printFunction f
-printObject _ (EnumObject e) = Right $ printEnum e
+printObject (EnumObject e) = printEnum e
--- |Checks the function inputs, output and assignment and converts it
+
-printObject (definedTypes, definedFunctions) (FunctionObject fun)
+-- |Checks all the objects from a list
-    | isRight checked = Right $ printFunction $ fromRightUnsafe checked
+checkObjects :: [(([Type], [Symbol]), (Header, [RosettaObject]))] -> [(Header, [Either [TypeCheckError] RosettaObject])]
-    | otherwise = Left $ fromLeftUnsafe checked
+checkObjects [] = []
+checkObjects (((definedTypes, definedSymbols), (header, objs)) : rest) = (header, checked) : checkObjects rest
     where
-        checked = checkFunction (definedTypes, definedFunctions) fun
+        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
 
@@ -99,3 +131,7 @@ parseType = do
 parseFunction :: Parser RosettaObject
 parseFunction = do
     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)

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.">
+import test.period.*
-    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">
 
 type TestType:
     testType int (1..1)

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">

src/Model/RosettaObject.hs

@@ -9,3 +9,4 @@ data RosettaObject =
     EnumObject EnumType
     | TypeObject Type
     | FunctionObject Function
+    deriving Show

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
+printImport name = "import" <+> pretty (removePeriods 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

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)

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