@@ -16,7 +16,7 @@ module Language.PureScript.Sugar.Names (
16 desugarImports
16 desugarImports
19−import Data.Maybe (fromMaybe, isJust)
19+import Data.Maybe (fromMaybe, isJust, fromJust)
20import Data.List (intersect, intercalate, (\\))
20import Data.List (intersect, intercalate, (\\))
21import Data.Data
21import Data.Data
22import Data.Generics (extM, mkM, everywhereM)
22import Data.Generics (extM, mkM, everywhereM)
@@ -35,20 +35,25 @@ import Language.PureScript.Types
35import Language.PureScript.Values
35import Language.PureScript.Values
38−-- The global export environment - every declaration exported from every module
38+-- The global export environment - every declaration exported from every module.
40−data ExportEnvironment = ExportEnvironment
40+type ExportEnvironment = M.Map ModuleName Exports
43+-- The exported declarations from a module.
45+data Exports = Exports
42 -- The types exported from each module
47 -- The types exported from each module
44− { exportedTypes :: M.Map ModuleName (S.Set (ProperName, [ProperName]))
49+ { exportedTypes :: S.Set (ProperName, [ProperName])
46 -- The classes exported from each module
51 -- The classes exported from each module
48− , exportedTypeClasses :: M.Map ModuleName (S.Set ProperName)
53+ , exportedTypeClasses :: S.Set ProperName
50 -- The values exported from each module
55 -- The values exported from each module
51− , exportedValues :: M.Map ModuleName (S.Set Ident)
56+ , exportedValues :: S.Set Ident
53 } deriving (Show)
58 } deriving (Show)
@@ -74,39 +79,48 @@ data ImportEnvironment = ImportEnvironment
74 , importedValues :: M.Map Ident (Qualified Ident)
79 , importedValues :: M.Map Ident (Qualified Ident)
75 } deriving (Show)
80 } deriving (Show)
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.
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
78-- Adds a type belonging to a module to the export environment.
93-- Adds a type belonging to a module to the export environment.
80addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
95addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
81−addType env mn name dctors = do
96+addType env mn name dctors = updateExportedModule env mn $ \m -> do
82− types <- addExport (exportedTypes env) mn (name, dctors)
97+ types <- addExport (exportedTypes m) (name, dctors)
83− return $ env { exportedTypes = types }
98+ return $ m { exportedTypes = types }
86-- Adds a class to the export environment.
101-- Adds a class to the export environment.
88addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
103addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
89−addTypeClass env mn name = do
104+addTypeClass env mn name = updateExportedModule env mn $ \m -> do
90− classes <- addExport (exportedTypeClasses env) mn name
105+ classes <- addExport (exportedTypeClasses m) name
91− return $ env { exportedTypeClasses = classes }
106+ return $ m { exportedTypeClasses = classes }
94-- Adds a class to the export environment.
109-- Adds a class to the export environment.
96addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
111addValue :: ExportEnvironment -> ModuleName -> Ident -> Either String ExportEnvironment
97−addValue env mn name = do
112+addValue env mn name = updateExportedModule env mn $ \m -> do
98− values <- addExport (exportedValues env) mn name
113+ values <- addExport (exportedValues m) name
99− return $ env { exportedValues = values }
114+ return $ m { exportedValues = values }
102-- Adds an export to a map of exports of that type.
117-- Adds an export to a map of exports of that type.
104−addExport :: (Ord s, Show s) => M.Map ModuleName (S.Set s) -> ModuleName -> s -> Either String (M.Map ModuleName (S.Set s))
119+addExport :: (Ord s, Show s) => S.Set s -> s -> Either String (S.Set s)
105−addExport exports mn name = case M.lookup mn exports of
120+addExport exports name =
106− Just s -> if S.member name s
121+ if S.member name exports
107− then throwError $ "Multiple definitions for '" ++ show name ++ "'"
122+ then throwError $ "Multiple definitions for '" ++ show name ++ "'"
108− else return $ M.insert mn (S.insert name s) exports
123+ else return $ S.insert name exports
109− Nothing -> return $ M.insert mn (S.singleton name) exports
112-- Replaces all local names with qualified names within a set of modules.
126-- Replaces all local names with qualified names within a set of modules.
@@ -173,7 +187,7 @@ renameInModule imports (Module mn decls) =
173-- Finds all exported declarations in a set of modules.
187-- Finds all exported declarations in a set of modules.
175findExports :: [Module] -> Either String ExportEnvironment
189findExports :: [Module] -> Either String ExportEnvironment
176−findExports = foldM addModule (ExportEnvironment M.empty M.empty M.empty)
190+findExports = foldM addModule M.empty
178 addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) env ds
192 addModule env m@(Module mn ds) = rethrowForModule m $ foldM (addDecl mn) env ds
179 addDecl mn env (TypeClassDeclaration tcn _ ds) = do
193 addDecl mn env (TypeClassDeclaration tcn _ ds) = do
@@ -206,84 +220,76 @@ findImports = foldl findImports' M.empty
207resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
221resolveImports :: ExportEnvironment -> Module -> Either String ImportEnvironment
208resolveImports env (Module currentModule decls) =
222resolveImports 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)
211 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
225 -- A Map from module name to imports from that module, where Nothing indicates everything is to be imported
212 scope :: M.Map ModuleName (Maybe ExplicitImports)
226 scope :: M.Map ModuleName (Maybe ExplicitImports)
213 scope = M.insert currentModule Nothing (findImports decls)
227 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
215− -- Add data to the ImportEnvironment
232+-- |
233+-- Extends the local environment for a module by resolving an import of another module.
216− resolveImport :: ImportEnvironment -> (ModuleName, Maybe ExplicitImports) -> Either String ImportEnvironment
235+resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ExplicitImports -> Either String ImportEnvironment
236+resolveImport currentModule importModule exp imp i = case i of
217− resolveImport imp (mn, Nothing) = importAll imp mn env
237+ Nothing -> importAll imp
218− resolveImport imp (mn, Just expl) = foldM (importExplicit mn) imp expl
238+ (Just expl) -> foldM importExplicit imp expl
241+ -- Import everything from a module
242+ importAll :: ImportEnvironment -> Either String ImportEnvironment
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)
220 -- Import something explicitly
248 -- Import something explicitly
221− importExplicit :: ModuleName -> ImportEnvironment -> ImportType -> Either String ImportEnvironment
249+ importExplicit :: ImportEnvironment -> ImportType -> Either String ImportEnvironment
222− importExplicit mn imp (NameImport name) = do
250+ importExplicit imp (NameImport name) = do
223− checkValueExists env mn name
251+ checkImportExists "value" values name
224− values' <- updateImports mn (importedValues imp) name
252+ values' <- updateImports (importedValues imp) name
225 return $ imp { importedValues = values' }
253 return $ imp { importedValues = values' }
226− importExplicit mn imp (TypeImport name dctors) = do
254+ importExplicit imp (TypeImport name dctors) = do
227− checkTypeExists env mn name
255+ checkImportExists "type" types name
228− types' <- updateImports mn (importedTypes imp) name
256+ types' <- updateImports (importedTypes imp) name
229− let allDctors = allExportedDataConstructors env mn name
257+ let allDctors = allExportedDataConstructors name
230− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists mn allDctors) dctors
258+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
231− dctors'' <- foldM (updateImports mn) (importedDataConstructors imp) dctors'
259+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
232 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
260 return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
233− importExplicit mn imp (TypeClassImport name) = do
261+ importExplicit imp (TypeClassImport name) = do
234− checkClassExists env mn name
262+ checkImportExists "type class" classes name
235− typeClasses' <- updateImports mn (importedTypeClasses imp) name
263+ typeClasses' <- updateImports (importedTypeClasses imp) name
236 return $ imp { importedTypeClasses = typeClasses' }
264 return $ imp { importedTypeClasses = typeClasses' }
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)
248 -- Find all exported data constructors for a given type
266 -- Find all exported data constructors for a given type
249− allExportedDataConstructors :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName]
267+ allExportedDataConstructors :: ProperName -> [ProperName]
250− allExportedDataConstructors env mn name = fromMaybe [] $ do
268+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` S.toList (exportedTypes exp)
251− s <- mn `M.lookup` exportedTypes env
252− name `lookup` S.toList s
254 -- Add something to the ImportEnvironment if it does not already exist there
270 -- 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))
271+ updateImports :: (Ord id, Show id) => M.Map id (Qualified id) -> id -> Either String (M.Map id (Qualified id))
256− updateImports mn m name = case M.lookup name m of
272+ updateImports m name = case M.lookup name m of
257− Nothing -> return $ M.insert name (Qualified (Just mn) name) m
273+ Nothing -> return $ M.insert name (Qualified (Just importModule) name) m
258− Just x@(Qualified (Just mn') _) -> throwError $
274+ Just x@(Qualified (Just mn) _) -> throwError $
259− if mn' == currentModule || mn == currentModule
275+ if mn == currentModule || importModule == currentModule
260− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
276+ then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just importModule) name) ++ "'"
261− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just mn) name) ++ "'"
277+ else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
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
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)
273− -- Ensure that an explicitly imported class exists in the module it is being imported from
279+ -- The available values, types, and classes in the module being imported
274− checkClassExists :: ExportEnvironment -> ModuleName -> ProperName -> Either String ProperName
280+ values = exportedValues exp
275− checkClassExists env mn = checkImportExists "type class" mn classes
281+ types = fst `S.map` exportedTypes exp
276− where classes = S.toList $ fromMaybe S.empty $ mn `M.lookup` exportedTypeClasses env
282+ classes = exportedTypeClasses exp
278 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
284 -- Ensure that an explicitly imported data constructor exists for the type it is being imported
280− checkDctorExists :: ModuleName -> [ProperName] -> ProperName -> Either String ProperName
286+ checkDctorExists :: [ProperName] -> ProperName -> Either String ProperName
281− checkDctorExists = checkImportExists "data constructor"
287+ checkDctorExists names = checkImportExists "data constructor" (S.fromList names)
283 -- Check that an explicitly imported item exists in the module it is being imported from
289 -- 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
290+ checkImportExists :: (Show a, Ord a, Eq a) => String -> S.Set a -> a -> Either String a
285− checkImportExists t mn exports item =
291+ checkImportExists t exports item =
286− if item `elem` exports
292+ if item `S.member` exports
287 then return item
293 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) ++ "'"