git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix up shadowed module names in JS codegen
e569230Gary Burgess
examples/passing/ShadowedModuleName.pursnew file+15
compare with golang
unifiedsplit
@@ -0,0 +1,15 @@
1+module Test where
2+
3+ data Z = Z String
4+
5+ runZ :: Z -> String
6+ runZ (Z s) = s
7+
8+module Main where
9+
10+ import Test
11+ import Control.Monad.Eff.Console
12+
13+ data Test = Test
14+
15+ main = log (runZ (Z "done"))
src/Language/PureScript/CodeGen/JS.hs+64−7
@@ -29,7 +29,8 @@ import Prelude ()
29import Prelude.Compat
29import Prelude.Compat
30
30
31import Data.List ((\\), delete, intersect)
31import Data.List ((\\), delete, intersect)
32−import Data.Maybe (isNothing)
32+import Data.Maybe (isNothing, fromMaybe)
33+import qualified Data.Map as M
33import qualified Data.Traversable as T (traverse)
34import qualified Data.Traversable as T (traverse)
34
35
35import Control.Arrow ((&&&))
36import Control.Arrow ((&&&))
@@ -60,8 +61,11 @@ moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSup
60 => Module Ann -> Maybe JS -> m [JS]
61 => Module Ann -> Maybe JS -> m [JS]
61moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
62moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
62 rethrow (addHint (ErrorInModule mn)) $ do
63 rethrow (addHint (ErrorInModule mn)) $ do
64+ let usedNames = concatMap getNames decls
65+ let mnLookup = renameImports usedNames imps
63− jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
66+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
67+ let decls' = renameModules mnLookup decls
64− jsDecls <- mapM bindToJs decls
68+ jsDecls <- mapM bindToJs decls'
65 optimized <- T.traverse (T.traverse optimize) jsDecls
69 optimized <- T.traverse (T.traverse optimize) jsDecls
66 comments <- not <$> asks optionsNoComments
70 comments <- not <$> asks optionsNoComments
67 let strict = JSStringLiteral "use strict"
71 let strict = JSStringLiteral "use strict"
@@ -77,13 +81,66 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
77 where
81 where
78
82
79 -- |
83 -- |
80− -- Generates Javascript code for a module import.
84+ -- Extracts all declaration names from a binding group.
81 --
85 --
86+ getNames :: Bind Ann -> [Ident]
87+ getNames (NonRec ident _) = [ident]
88+ getNames (Rec vals) = map fst vals
89+
90+ -- |
91+ -- Creates alternative names for each module to ensure they don't collide
92+ -- with declaration names.
93+ --
94+ renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
95+ renameImports ids mns = go M.empty ids mns
96+ where
97+ go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
98+ go acc used (mn' : mns') =
99+ let mni = Ident $ runModuleName mn'
100+ in if mni `elem` used
101+ then let newName = freshModuleName 1 mn' used
102+ in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'
103+ else go (M.insert mn' mn' acc) (mni : used) mns'
104+ go acc _ [] = acc
105+
106+ freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
107+ freshModuleName i mn'@(ModuleName pns) used =
108+ let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i]
109+ in if Ident (runModuleName newName) `elem` used
110+ then freshModuleName (i + 1) mn' used
111+ else newName
112+
113+ -- |
114+ -- Generates Javascript code for a module import, binding the required module
115+ -- to the alternative
116+ --
82− importToJs :: ModuleName -> m JS
117+ importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS
83− importToJs mn' = do
118+ importToJs mnLookup mn' = do
84 path <- asks optionsRequirePath
119 path <- asks optionsRequirePath
120+ let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
85 let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]
121 let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]
86− return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)
122+ return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)
123+
124+ -- |
125+ -- Replaces the `ModuleName`s in the AST so that the generated code refers to
126+ -- the collision-avoiding renamed module imports.
127+ --
128+ renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]
129+ renameModules mnLookup binds =
130+ let (f, _, _) = everywhereOnValues id goExpr goBinder
131+ in map f binds
132+ where
133+ goExpr :: Expr a -> Expr a
134+ goExpr (Var ann q) = Var ann (renameQual q)
135+ goExpr e = e
136+ goBinder :: Binder a -> Binder a
137+ goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
138+ goBinder b = b
139+ renameQual :: Qualified a -> Qualified a
140+ renameQual (Qualified (Just mn') a) =
141+ let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
142+ in Qualified (Just mnSafe) a
143+ renameQual q = q
87
144
88 -- |
145 -- |
89 -- Generate code in the simplified Javascript intermediate representation for a declaration
146 -- Generate code in the simplified Javascript intermediate representation for a declaration