Parse module name with dots

garyb · garyb · commit 34f0cd8dcb9c · 2014-02-17T21:58:36.000Z
diff --git a/examples/passing/DottedModules.purs b/examples/passing/DottedModules.purs
@@ -0,0 +1,16 @@
+module Some.Module.Name where
+
+  class Foo a where
+    foo :: a -> a
+  
+  x = "Done"
+
+module Main where
+
+  import Prelude
+  import Some.Module.Name
+  
+  instance Some.Module.Name.Foo String where
+    foo s = s
+
+  main = Trace.print $ foo x
diff --git a/src/Language/PureScript/CodeGen/Common.hs b/src/Language/PureScript/CodeGen/Common.hs
@@ -16,6 +16,7 @@
 module Language.PureScript.CodeGen.Common where
 
 import Data.Char
+import Data.List (intercalate)
 import Language.PureScript.Names
 
 -- |
@@ -127,3 +128,5 @@ nameIsJsReserved name =
             , "with"
             , "yield" ]
 
+moduleNameToJs :: ModuleName -> String
+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
@@ -23,7 +23,7 @@ module Language.PureScript.CodeGen.JS (
 ) where
 
 import Data.Maybe (fromMaybe, mapMaybe)
-import Data.List (sortBy, intercalate)
+import Data.List (sortBy)
 import Data.Function (on)
 import Data.Data (Data)
 import Data.Generics (mkQ, everything)
@@ -55,15 +55,12 @@ moduleToJs :: Options -> Module -> Environment -> Maybe JS
 moduleToJs opts (Module name decls) env =
   case jsDecls of
     [] -> Nothing
-    _ -> Just $ JSAssignment (JSAccessor (moduleNameToJS name) (JSVar "_ps")) $
+    _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $
            JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
-                 [(JSBinary Or (JSAccessor (moduleNameToJS name) (JSVar "_ps")) (JSObjectLiteral []))]
+                 [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]
   where
   jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))
 
-moduleNameToJS :: ModuleName -> String
-moduleNameToJS (ModuleName pns) = intercalate "_" (runProperName `map` pns)
-
 -- |
 -- Generate code in the simplified Javascript intermediate representation for a declaration
 --
@@ -215,7 +212,7 @@ varToJs m e qual@(Qualified _ ident) = go qual
 -- variable that may have a qualified name.
 --
 qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
-qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJS m') $ JSVar "_ps")
+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")
 qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)
 
 -- |
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
@@ -203,15 +203,24 @@ natural = PT.natural tokenParser
 properName :: P.Parsec String u ProperName
 properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")
 
+-- |
+-- Parse a module name
+--
+moduleName :: P.Parsec String ParseState ModuleName
+moduleName = ModuleName <$> P.try (sepBy properName dot)
+
 -- |
 -- Parse a qualified name, i.e. M.name or just name
 --
 parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
-parseQualified parser = qual
+parseQualified parser = part []
   where
-  qual = (Qualified <$> (Just . ModuleName . pure <$> P.try (properName <* delimiter)) <*> parser)
-     <|> (Qualified Nothing <$> P.try parser)
-  delimiter = indented *> dot
+  part path = (do name <- P.try (properName <* delimiter)
+                  part (updatePath path name))
+              <|> (Qualified (qual path) <$> P.try parser)
+  delimiter = indented *> dot <* P.notFollowedBy dot
+  updatePath path name = path ++ [name]
+  qual path = if null path then Nothing else Just $ ModuleName path
 
 -- |
 -- Parse an integer or floating point value
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
@@ -89,7 +89,7 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration
 parseImportDeclaration = do
   reserved "import"
   indented
-  moduleName <- ModuleName . pure <$> properName
+  moduleName <- moduleName
   idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
   return $ ImportDeclaration moduleName idents
 
@@ -138,10 +138,10 @@ parseModule :: P.Parsec String ParseState Module
 parseModule = do
   reserved "module"
   indented
-  name <- properName
+  name <- moduleName
   _ <- lexeme $ P.string "where"
   decls <- mark (P.many (same *> parseDeclaration))
-  return $ Module (ModuleName [name]) decls
+  return $ Module name decls
 
 -- |
 -- Parse a collection of modules
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -36,7 +36,7 @@ import Control.Arrow ((***))
 import Data.Maybe (fromMaybe)
 import Data.List (nub)
 import Data.Generics (mkQ, everything)
-import Language.PureScript.CodeGen.Common (identToJs)
+import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)
 
 type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
 
@@ -159,7 +159,7 @@ typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in
 
 qualifiedToString :: ModuleName -> Qualified ProperName -> String
 qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)
-qualifiedToString _ (Qualified (Just mn) pn) = runModuleName mn ++ "_" ++ runProperName pn
+qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
 
 -- |
 -- Generate a name for a type class dictionary, based on the module name, class name and type name
