@@ -26,35 +26,69 @@ import Language.PureScript.Names
2626import Language.PureScript.Types
2727import Language.PureScript.Values
2828
29+-- |
30+-- The global export environment - every declaration exported from every module
31+--
2932data ExportEnvironment = ExportEnvironment
33+ -- |
34+ -- The types exported from each module
35+ --
3036 { exportedTypes :: M.Map ModuleName (S.Set ProperName)
31− , exportedDataConstructors :: M.Map ModuleName (S.Set ProperName)
37+ -- |
38+ -- The data constructors exported from each module, grouped by type constructor
39+ --
40+ , exportedDataConstructors :: M.Map ModuleName (S.Set (ProperName, [ProperName]))
41+ -- |
42+ -- The classes exported from each module
43+ --
3244 , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
3345 } deriving (Show)
34−
46+
47+-- |
48+-- An imported environment for a particular module. This also contains the module's own members.
49+--
3550data ImportEnvironment = ImportEnvironment
51+ -- |
52+ -- Local names for types within a module mapped to to their qualified names
53+ --
3654 { importedTypes :: M.Map ProperName (Qualified ProperName)
55+ -- |
56+ -- Local names for data constructors within a module mapped to to their qualified names
57+ --
3758 , importedDataConstructors :: M.Map ProperName (Qualified ProperName)
59+ -- |
60+ -- Local names for classes within a module mapped to to their qualified names
61+ --
3862 , importedTypeClasses :: M.Map ProperName (Qualified ProperName)
3963 } deriving (Show)
4064
41−nullEnv = ExportEnvironment M.empty M.empty M.empty
42−
65+-- |
66+-- Adds a type belonging to a module to the export environment.
67+--
4368addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
4469addType env mn name = do
4570 types <- addExport (exportedTypes env) mn name
4671 return $ env { exportedTypes = types }
4772
48−addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
49−addDataConstructor env mn name = do
50− dataConstructors <- addExport (exportedDataConstructors env) mn name
73+-- |
74+-- Adds a group of data constructors with their associated type constructor the export environment.
75+--
76+addDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
77+addDataConstructors env mn tcon dcons = do
78+ dataConstructors <- addExport (exportedDataConstructors env) mn (tcon, dcons)
5179 return $ env { exportedDataConstructors = dataConstructors }
5280
81+-- |
82+-- Adds a class to the export environment.
83+--
5384addTypeclass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
5485addTypeclass env mn name = do
5586 classes <- addExport (exportedTypeClasses env) mn name
5687 return $ env { exportedTypeClasses = classes }
5788
89+-- |
90+-- Adds an export to a map of exports of that type.
91+--
5892addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
5993addExport exports mn name = case M.lookup mn exports of
6094 Just s -> if S.member name s
@@ -62,6 +96,9 @@ addExport exports mn name = case M.lookup mn exports of
6296 else Right $ M.insert mn (S.insert name s) exports
6397 Nothing -> Right $ M.insert mn (S.singleton name) exports
6498
99+-- |
100+-- Replaces all local names with qualified names within a set of modules.
101+--
65102rename :: [Module] -> Either String [Module]
66103rename modules = do
67104 exports <- findExports modules
@@ -71,14 +108,17 @@ rename modules = do
71108 imports <- resolveImports exports m
72109 renameInModule imports m
73110
111+-- |
112+-- Replaces all local names with qualified names within a module.
113+--
74114renameInModule :: ImportEnvironment -> Module -> Either String Module
75115renameInModule imports (Module mn decls) =
76116 Module mn <$> mapM updateDecl decls >>= everywhereM ((mkM updateType) `extM` updateValue `extM` updateBinder)
77117 where
78118 updateDecl (TypeInstanceDeclaration cs (Qualified Nothing cn) ts ds) = do
79− cn' <- updateClassName cn
80− cs' <- updateConstraints cs
81− return $ TypeInstanceDeclaration cs' cn' ts ds
119+ cn' <- updateClassName cn
120+ cs' <- updateConstraints cs
121+ return $ TypeInstanceDeclaration cs' cn' ts ds
82122 updateDecl d = return d
83123 updateValue (Constructor (Qualified Nothing nm)) = liftM Constructor $ updateDataConstructorName nm
84124 updateValue v = return v
@@ -93,42 +133,72 @@ renameInModule imports (Module mn decls) =
93133 updateType t = return t
94134 updateConstraints = mapM updateConstraint
95135 updateConstraint (Qualified Nothing nm, ts) = do
96− nm' <- updateClassName nm
97− return (nm', ts)
136+ nm' <- updateClassName nm
137+ return (nm', ts)
98138 updateConstraint other = return other
99139 updateTypeName = update "type" importedTypes
100140 updateClassName = update "typeclass" importedTypeClasses
101141 updateDataConstructorName = update "data constructor" importedDataConstructors
102142 update t get nm = maybe (Left $ "Unknown " ++ t ++ " '" ++ show nm ++ "' in module '" ++ show mn ++ "'") return $ M.lookup nm (get imports)
103−
143+
144+-- |
145+-- Finds all exported declarations in a set of modules.
146+--
104147findExports :: [Module] -> Either String ExportEnvironment
105−findExports = foldM addModule nullEnv
148+findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)
106149 where
107150 addModule env (Module mn ds) = foldM (addDecl mn) env ds
108151 addDecl mn env (TypeClassDeclaration tcn _ _) = addTypeclass env mn tcn
109152 addDecl mn env (DataDeclaration tn _ dcs) = do
110− env' <- foldM (`addDataConstructor` mn) env (map fst dcs)
111− addType env' mn tn
153+ env' <- addDataConstructors env mn tn (map fst dcs)
154+ addType env' mn tn
112155 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn
113156 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn
114157 addDecl _ env _ = return env
115158
116−findImports :: [Declaration] -> [ModuleName]
117−findImports decls = [ mn | (ImportDeclaration mn Nothing) <- decls ]
159+-- |
160+-- Type representing a set of declarations being explicitly imported from a module
161+--
162+type ExplicitImports = [Either Ident ProperName]
163+
164+-- |
165+-- Finds the imports within a module, mapping the imported module name to an optional set of
166+-- explicitly imported declarations.
167+--
168+findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports)
169+findImports = foldl findImports' M.empty
170+ where
171+ findImports' result (ImportDeclaration mn Nothing) = M.insert mn Nothing result
172+ findImports' result (ImportDeclaration mn (Just expl)) = M.insert mn (Just expl) result
173+ findImports' result _ = result
118174
175+-- |
176+-- Constructs a local environment for a module.
177+--
119178resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
120179resolveImports env (Module currentModule decls) = do
121− types <- resolve exportedTypes
122− dataConstructors <- resolve exportedDataConstructors
123− typeClasses <- resolve exportedTypeClasses
180+ types <- resolve exportedTypes (resolveDefs filterTypes)
181+ dataConstructors <- resolve exportedDataConstructors resolveDcons
182+ typeClasses <- resolve exportedTypeClasses (resolveDefs filterClasses)
124183 return $ ImportEnvironment types dataConstructors typeClasses
125184 where
126− scope = currentModule : findImports decls
127− resolve get = foldM resolveDefs M.empty (M.toList $ get env)
128− resolveDefs result (mn, names) | mn `elem` scope = foldM (resolveDef mn) result (S.toList names)
129− resolveDefs result _ = return result
185+ scope = M.insert currentModule Nothing (findImports decls)
186+ resolve get f = foldM f M.empty (M.toList $ get env)
187+ resolveDefs filt result (mn, names) = case M.lookup mn scope of
188+ Just Nothing -> foldM (resolveDef mn) result (S.toList names)
189+ Just (Just expl) -> foldM (resolveDef mn) result (S.toList (S.intersection names (foldl filt S.empty expl)))
190+ Nothing -> Right result
130191 resolveDef mn result name = case M.lookup name result of
131192 Nothing -> return $ M.insert name (Qualified (Just mn) name) result
132− Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++ if mn' == currentModule
193+ Just x@(Qualified (Just mn') _) -> Left $ "Module '" ++ show currentModule ++
194+ if mn' == currentModule || mn == currentModule
133195 then "' defines '" ++ show name ++ "' which conflicts with imported definition '" ++ show (Qualified (Just mn) name) ++ "'"
134196 else "' has conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
197+ resolveDcons result (mn, tcons) = case M.lookup mn scope of
198+ Just Nothing -> foldM (\result (tcon, dcons) -> foldM (resolveDef mn) result dcons) result (S.toList tcons)
199+ Just (Just expl) ->
200+ let selectedTcons = filter (\(tcon, _) -> any (either (const False) ((==) tcon)) expl) (S.toList tcons) in
201+ foldM (\result (tcon, dcons) -> foldM (resolveDef mn) result dcons) result selectedTcons
202+ Nothing -> Right result
203+ filterTypes result = either (const result) (`S.insert` result)
204+ filterClasses result _ = result