@@ -16,7 +16,7 @@ module Language.PureScript.Sugar.Names (
1616 desugarImports
1717) where
1818
19−import Data.Maybe (fromMaybe, isJust)
19+import Data.Maybe (fromMaybe, isJust, fromJust)
2020import Data.List (intersect, intercalate, (\\))
2121import Data.Data
2222import Data.Generics (extM, mkM, everywhereM)
@@ -35,20 +35,25 @@ import Language.PureScript.Types
3535import Language.PureScript.Values
3636
3737-- |
38−-- The global export environment - every declaration exported from every module
38+-- The global export environment - every declaration exported from every module.
3939--
40−data ExportEnvironment = ExportEnvironment
40+type ExportEnvironment = M.Map ModuleName Exports
41+
42+-- |
43+-- The exported declarations from a module.
44+--
45+data Exports = Exports
4146 -- |
4247 -- The types exported from each module
4348 --
44− { exportedTypes :: M.Map ModuleName (S.Set (ProperName, [ProperName]))
49+ { exportedTypes :: S.Set (ProperName, [ProperName])
4550 -- |
4651 -- The classes exported from each module
4752 --
48− , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
53+ , exportedTypeClasses :: S.Set ProperName
4954 -- |
5055 -- The values exported from each module
51− , exportedValues :: M.Map ModuleName (S.Set Ident)
56+ , exportedValues :: S.Set Ident
5257 --
5358 } deriving (Show)
5459
@@ -74,39 +79,48 @@ data ImportEnvironment = ImportEnvironment
7479 , importedValues :: M.Map Ident (Qualified Ident)
7580 } deriving (Show)
7681
82+-- |
83+-- Updates the exports for a module from the global environment. If the module was not previously
84+-- present in the global environment, it is created.
85+--
86+updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either String Exports) -> Either String ExportEnvironment
87+updateExportedModule env mn update = do
88+ let exports = fromMaybe (Exports S.empty S.empty S.empty) $ mn `M.lookup` env
89+ exports' <- update exports
90+ return $ M.insert mn exports' env
91+
7792-- |
7893-- Adds a type belonging to a module to the export environment.
7994--
8095addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
81−addType env mn name dctors = do
82− types <- addExport (exportedTypes env) mn (name, dctors)
83− return $ env { exportedTypes = types }
96+addType env mn name dctors = updateExportedModule env mn $ \m -> do
97+ types <- addExport (exportedTypes m) (name, dctors)
98+ return $ m { exportedTypes = types }
8499
85100-- |
86101-- Adds a class to the export environment.
87102--
88103addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
89−addTypeClass env mn name = do
90− classes <- addExport (exportedTypeClasses env) mn name
91− return $ env { exportedTypeClasses = classes }
104+addTypeClass env mn name = updateExportedModule env mn $ \m -> do
105+ classes <- addExport (exportedTypeClasses m) name
106+ return $ m { exportedTypeClasses = classes }
92107
93108-- |
94109-- Adds a class to the export environment.
95110--
96111addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
97−addValue env mn name = do
98− values <- addExport (exportedValues env) mn name
99− return $ env { exportedValues = values }
112+addValue env mn name = updateExportedModule env mn $ \m -> do
113+ values <- addExport (exportedValues m) name
114+ return $ m { exportedValues = values }
100115
101116-- |
102117-- Adds an export to a map of exports of that type.
103118--
104−addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
105−addExport exports mn name = case M.lookup mn exports of
106− Just s -> if S.member name s
107− then throwError $ "Multiple definitions for '" ++ show name ++ "'"
108− else return $ M.insert mn (S.insert name s) exports
109− Nothing -> return $ M.insert mn (S.singleton name) exports
119+addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)
120+addExport exports name =
121+ if S.member name exports
122+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
123+ else return $ S.insert name exports
110124
111125-- |
112126-- Replaces all local names with qualified names within a set of modules.
@@ -173,7 +187,7 @@ renameInModule imports (Module mn decls) =
173187-- Finds all exported declarations in a set of modules.
174188--
175189findExports :: [Module] -> Either String ExportEnvironment
176−findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)
190+findExports = foldM addModule M.empty
177191 where
178192 addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) env ds
179193 addDecl mn env (TypeClassDeclaration tcn _ ds) = do
@@ -206,84 +220,76 @@ findImports = foldl findImports' M.empty
206220--
207221resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
208222resolveImports env (Module currentModule decls) =
209− foldM resolveImport (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
223+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
210224 where
211225 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
212226 scope :: M.Map ModuleName (Maybe ExplicitImports)
213227 scope = M.insert currentModule Nothing (findImports decls)
228+ resolveImport' imp (mn, i) = do
229+ m <- maybe (throwError $ "Cannot import from unknown module '" ++ show mn ++ "'") return $ mn `M.lookup` env
230+ resolveImport currentModule mn m imp i
214231
215− -- Add data to the ImportEnvironment
216− resolveImport :: ImportEnvironment -> (ModuleName, Maybe ExplicitImports) -> Either String ImportEnvironment
217− resolveImport imp (mn, Nothing) = importAll imp mn env
218− resolveImport imp (mn, Just expl) = foldM (importExplicit mn) imp expl
232+-- |
233+-- Extends the local environment for a module by resolving an import of another module.
234+--
235+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
236+resolveImport currentModule importModule exp imp i = case i of
237+ Nothing -> importAll imp
238+ (Just expl) -> foldM importExplicit imp expl
239+ where
240+
241+ -- Import everything from a module
242+ importAll :: ImportEnvironment -> Either String ImportEnvironment
243+ importAll imp = do
244+ imp' <- foldM (\m (name, dctors) -> importExplicit m (TypeImport name (Just dctors))) imp (S.toList $ exportedTypes exp)
245+ imp'' <- foldM (\m name -> importExplicit m (NameImport name)) imp' (S.toList $ exportedValues exp)
246+ foldM (\m name -> importExplicit m (TypeClassImport name)) imp'' (S.toList $ exportedTypeClasses exp)
219247
220248 -- Import something explicitly
221− importExplicit :: ModuleName -> ImportEnvironment -> ImportType -> Either String ImportEnvironment
222− importExplicit mn imp (NameImport name) = do
223− checkValueExists env mn name
224− values' <- updateImports mn (importedValues imp) name
249+ importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment
250+ importExplicit imp (NameImport name) = do
251+ checkImportExists "value" values name
252+ values' <- updateImports (importedValues imp) name
225253 return $ imp { importedValues = values' }
226− importExplicit mn imp (TypeImport name dctors) = do
227− checkTypeExists env mn name
228− types' <- updateImports mn (importedTypes imp) name
229− let allDctors = allExportedDataConstructors env mn name
230− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists mn allDctors) dctors
231− dctors'' <- foldM (updateImports mn) (importedDataConstructors imp) dctors'
254+ importExplicit imp (TypeImport name dctors) = do
255+ checkImportExists "type" types name
256+ types' <- updateImports (importedTypes imp) name
257+ let allDctors = allExportedDataConstructors name
258+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
259+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
232260 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
233− importExplicit mn imp (TypeClassImport name) = do
234− checkClassExists env mn name
235− typeClasses' <- updateImports mn (importedTypeClasses imp) name
261+ importExplicit imp (TypeClassImport name) = do
262+ checkImportExists "type class" classes name
263+ typeClasses' <- updateImports (importedTypeClasses imp) name
236264 return $ imp { importedTypeClasses = typeClasses' }
237265
238− -- Import everything from a module
239− importAll :: ImportEnvironment -> ModuleName -> ExportEnvironment -> Either String ImportEnvironment
240− importAll imp mn env = do
241− imp' <- foldM (\m (name, dctors) -> importExplicit mn m (TypeImport name (Just dctors))) imp
242− (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedTypes env)
243− imp'' <- foldM (\m name -> importExplicit mn m (NameImport name)) imp'
244− (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedValues env)
245− foldM (\m name -> importExplicit mn m (TypeClassImport name)) imp''
246− (S.toList . fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env)
247−
248266 -- Find all exported data constructors for a given type
249− allExportedDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName]
250− allExportedDataConstructors env mn name = fromMaybe [] $ do
251− s <- mn `M.lookup` exportedTypes env
252− name `lookup` S.toList s
267+ allExportedDataConstructors :: ProperName -> [ProperName]
268+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)
253269
254270 -- Add something to the ImportEnvironment if it does not already exist there
255− updateImports :: (Ord id, Show id) => ModuleName -> M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
256− updateImports mn m name = case M.lookup name m of
257− Nothing -> return $ M.insert name (Qualified (Just mn) name) m
258− Just x@(Qualified (Just mn') _) -> throwError $
259− if mn' == currentModule || mn == currentModule
260− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
261− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
262−
263− -- Ensure that an explicitly imported value exists in the module it is being imported from
264− checkValueExists :: ExportEnvironment -> ModuleName -> Ident -> Either String Ident
265− checkValueExists env mn = checkImportExists "value" mn values
266− where values = S.toList $ fromMaybe S.empty $ mn `M.lookup` exportedValues env
267−
268− -- Ensure that an explicitly imported type exists in the module it is being imported from
269− checkTypeExists :: ExportEnvironment -> ModuleName -> ProperName -> Either String ProperName
270− checkTypeExists env mn = checkImportExists "type" mn types
271− where types = fst `map` S.toList (fromMaybe S.empty $ mn `M.lookup` exportedTypes env)
271+ updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
272+ updateImports m name = case M.lookup name m of
273+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
274+ Just x@(Qualified (Just mn) _) -> throwError $
275+ if mn == currentModule || importModule == currentModule
276+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
277+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
272278
273− -- Ensure that an explicitly imported class exists in the module it is being imported from
274− checkClassExists :: ExportEnvironment -> ModuleName -> ProperName -> Either String ProperName
275− checkClassExists env mn = checkImportExists "type class" mn classes
276− where classes = S.toList $ fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env
279+ -- The available values, types, and classes in the module being imported
280+ values = exportedValues exp
281+ types = fst `S.map` exportedTypes exp
282+ classes = exportedTypeClasses exp
277283
278284 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
279285 -- from
280− checkDctorExists :: ModuleName -> [ProperName] -> ProperName -> Either String ProperName
281− checkDctorExists = checkImportExists "data constructor"
286+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
287+ checkDctorExists names = checkImportExists "data constructor" (S.fromList names)
282288
283289 -- Check that an explicitly imported item exists in the module it is being imported from
284− checkImportExists :: (Show a, Eq a) => String -> ModuleName -> [a] -> a -> Either String a
285− checkImportExists t mn exports item =
286− if item `elem` exports
290+ checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a
291+ checkImportExists t exports item =
292+ if item `S.member` exports
287293 then return item
288− else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just mn) item) ++ "'"
294+ else throwError $ "Unable to find " ++ t ++ " '" ++ show (Qualified (Just importModule) item) ++ "'"
289295