@@ -98,21 +98,11 @@ addEmptyModule env name = M.insert name (Exports S.empty S.empty S.empty) env
9898-- |
9999-- Adds a type belonging to a module to the export environment.
100100--
101−addType :: ExportEnvironment -> ModuleName -> ProperName -> Either String ExportEnvironment
102−addType env mn name = updateExportedModule env mn $ \m -> do
103− types <- addExport (exportedTypes m) (name, [])
101+addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either String ExportEnvironment
102+addType env mn name dctors = updateExportedModule env mn $ \m -> do
103+ types <- addExport (exportedTypes m) (name, dctors)
104104 return $ m { exportedTypes = types }
105105
106−-- |
107−-- Adds a data constructor belonging to a type and module to the export environment.
108−--
109−addDataConstructor :: ExportEnvironment -> ModuleName -> ProperName -> ProperName -> Either String ExportEnvironment
110−addDataConstructor env mn tcon dcon = updateExportedModule env mn $ \m -> do
111− let types = exportedTypes m
112− let dcons = fromMaybe (error $ "Type '" ++ show tcon ++ "' is missing from exportedTypes") (tcon `lookup` (S.toList types))
113− let types' = S.insert (tcon, dcon : dcons) $ S.delete (tcon, dcons) types
114− return $ m { exportedTypes = types' }
115−
116106-- |
117107-- Adds a class to the export environment.
118108--
@@ -211,39 +201,73 @@ findExports = foldM addModule M.empty
211201
212202 -- Add all of the exported declarations from a module to the global export environment
213203 addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
214− addModule env m@(Module mn ds exps) = rethrowForModule m $ foldM (addDecl mn exps) (addEmptyModule env mn) ds
215−
216− -- Add a declaration from a module to the global export environment, ensuring it is exported
217− -- from the module it resides within
218− addDecl :: ModuleName -> Maybe [DeclarationRef] -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
219− addDecl mn exps env (TypeClassDeclaration tcn _ ds) | isExported (TypeClassRef tcn) exps = do
204+ addModule env m@(Module mn ds Nothing) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds
205+ addModule env m@(Module mn ds (Just exps)) = rethrowForModule m $ do
206+ env' <- foldM (addDecl mn) (addEmptyModule env mn) ds
207+ filterExports mn exps env'
208+
209+ -- Add a declaration from a module to the global export environment
210+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
211+ addDecl mn env (TypeClassDeclaration tcn _ ds) = do
220212 env' <- addTypeClass env mn tcn
221− foldM (addClassMember mn exps) env' ds
222− addDecl mn exps env (DataDeclaration tn _ dcs) | isExported (TypeRef tn Nothing) exps = do
223− env' <- addType env mn tn
224− foldM (\env'' -> addDataConstructor env'' mn tn) env' (map fst dcs)
225− addDecl mn exps env (TypeSynonymDeclaration tn _ _) | isExported (TypeRef tn Nothing) exps = addType env mn tn
226− addDecl mn exps env (ExternDataDeclaration tn _) | isExported (TypeRef tn Nothing) exps = addType env mn tn
227− addDecl mn exps env (ValueDeclaration name _ _ _) | isExported (ValueRef name) exps = addValue env mn name
228− addDecl mn exps env (ExternDeclaration _ name _ _) | isExported (ValueRef name) exps = addValue env mn name
229− addDecl _ _ env _ = return env
230−
231− -- Add a class member from a module to the global export environment, ensuring it is exported
232− -- from the module it resides within
233− addClassMember :: ModuleName -> Maybe [DeclarationRef] -> ExportEnvironment -> Declaration -> Either String ExportEnvironment
234− addClassMember mn exps env (TypeDeclaration name _) | isExported (ValueRef name) exps = addValue env mn name
235− addClassMember mn exps env _ = return env
236−
237− -- Check whether a declaration is exported from a module. When checking if a type is exported
238− -- the specific data constructors are ignored, only the export for the type constructor is
239− -- tested for.
240− isExported :: DeclarationRef -> Maybe [DeclarationRef] -> Bool
241− isExported (TypeRef tn _) (Just exps) = any (typeMatches tn) exps
242− where
243− typeMatches tn (TypeRef tn' _) = tn == tn'
244− typeMatches _ _ = False
245− isExported dec (Just exps) = dec `elem` exps
246− isExported dec Nothing = True
213+ foldM (\env'' (TypeDeclaration name _) -> addValue env'' mn name) env' ds
214+ addDecl mn env (DataDeclaration tn _ dcs) = addType env mn tn (map fst dcs)
215+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
216+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
217+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
218+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
219+ addDecl _ env _ = return env
220+
221+-- |
222+-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
223+-- environment.
224+--
225+filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either String ExportEnvironment
226+filterExports mn exps env = do
227+ let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
228+ moduleExports' <- filterModule exps moduleExports
229+ return $ M.insert mn moduleExports' env
230+ where
231+
232+ -- Filter the exports for the specific module
233+ filterModule :: [DeclarationRef] -> Exports -> Either String Exports
234+ filterModule exps exported = do
235+ types <- foldM (filterTypes $ S.toList $ exportedTypes exported) S.empty exps
236+ values <- foldM (filterValues $ exportedValues exported) S.empty exps
237+ classes <- foldM (filterClasses $ exportedTypeClasses exported) S.empty exps
238+ return exported { exportedTypes = types, exportedTypeClasses = classes, exportedValues = values }
239+
240+ -- Ensure the exported types and data constructors exist in the module and add them to the set of
241+ -- exports
242+ filterTypes :: [(ProperName, [ProperName])] -> S.Set (ProperName, [ProperName]) -> DeclarationRef -> Either String (S.Set (ProperName, [ProperName]))
243+ filterTypes exps result (TypeRef name expDcons) = do
244+ dcons <- maybe (throwError $ "Cannot export undefined type '" ++ show name ++ "'") return $ name `lookup` exps
245+ dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
246+ return $ S.insert (name, dcons') result
247+ filterTypes exps result _ = return result
248+
249+ -- Ensure the exported data constructors exists for a type and add them to the list of exports
250+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either String [ProperName]
251+ filterDcons tcon exps result name =
252+ if name `elem` exps
253+ then return $ name : result
254+ else throwError $ "Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'"
255+
256+ -- Ensure the exported classes exist in the module and add them to the set of exports
257+ filterClasses :: S.Set ProperName -> S.Set ProperName -> DeclarationRef -> Either String (S.Set ProperName)
258+ filterClasses exps result (TypeClassRef name) =
259+ if name `S.member` exps
260+ then return $ S.insert name result
261+ else throwError $ "Cannot export undefined type class '" ++ show name ++ "'"
262+ filterClasses exps result _ = return result
263+
264+ -- Ensure the exported values exist in the module and add them to the set of exports
265+ filterValues :: S.Set Ident -> S.Set Ident -> DeclarationRef -> Either String (S.Set Ident)
266+ filterValues exps result (ValueRef name) =
267+ if name `S.member` exps
268+ then return $ S.insert name result
269+ else throwError $ "Cannot export undefined value '" ++ show name ++ "'"
270+ filterValues exps result _ = return result
247271
248272-- |
249273-- Type representing a set of declarations being explicitly imported from a module