-rnExports :: [Module]
- -> Bag (Module,RnName)
- -> Maybe [RdrNameIE]
- -> RnM s (Name -> ExportFlag)
-
-rnExports mods unqual_imps Nothing
- = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
-
-rnExports mods unqual_imps (Just exps)
- = getModuleRn `thenRn` \ this_mod ->
- getRnEnv `thenRn` \ rn_env ->
- mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
- let
- (tc_bags, val_bags) = unzip exp_bags
- tc_names = bagToList (unionManyBags tc_bags)
- val_names = bagToList (unionManyBags val_bags)
- exp_mods = catMaybes mod_maybes
-
- -- Warn for duplicate names and modules
- (_, dup_tc_names) = removeDups cmp_fst tc_names
- (_, dup_val_names) = removeDups cmp_fst val_names
- cmp_fst (x,_) (y,_) = x `cmp` y
-
- (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
- (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
-
- -- Get names for module This_Mod export
- (this_tcs, this_vals)
- = if null expmods_this
- then ([], [])
- else getLocalsFromRnEnv rn_env
-
- -- Get names for exported imported modules
- (mod_tcs, mod_vals, empty_mods)
- = case mapAndUnzip3 get_mod_names expmods_imps of
- (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
-
- (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
-
- get_mod_names mod
- = (tcs, vals, empty_mod)
- where
- tcs = [(getName rn, nameImportFlag (getName rn))
- | (mod',rn) <- unqual_tcs, mod == mod']
- vals = [(getName rn, nameImportFlag (getName rn))
- | (mod',rn) <- unqual_vals, mod == mod']
- empty_mod = if null tcs && null vals
- then Just mod
- else Nothing
-
- -- Build finite map of exported names to export flag
- tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
- tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
- tc_map = addListToUFM_C lub_expflag tc_map1 (map (pair_fst.exp_all) this_tcs)
-
- val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
- val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
- val_map = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals)
-
- pair_fst pr@(n,_) = (n,pr)
- exp_all rn = (getName rn, ExportAll)
- lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
-
- -- Check for exporting of duplicate local names
- tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
- val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
- (_, dup_tc_locals) = removeDups cmp_local tc_locals
- (_, dup_val_locals) = removeDups cmp_local val_locals
- cmp_local (x,_) (y,_) = x `cmpPString` y
-
- -- Build export flag function
- final_exp_map = plusUFM tc_map val_map
- exp_fn n = case lookupUFM final_exp_map n of
- Nothing -> NotExported
- Just (_,flag) -> flag
- in
- getSrcLocRn `thenRn` \ src_loc ->
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_`
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_`
- mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
- mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
- returnRn exp_fn
-
-
-rnIE mods (IEVar name)
- = lookupValue name `thenRn` \ rn ->
- checkIEVar rn `thenRn` \ exps ->
- returnRn (Nothing, exps)
- where
- checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll))
- checkIEVar (WiredInId i) = returnRn (emptyBag, unitBag (getName i, ExportAll))
- checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
- checkIEVar rn@(RnField _ _) = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc)
- checkIEVar rn = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $
- returnRn (emptyBag, emptyBag)
-
-rnIE mods (IEThingAbs name)
- = lookupTyConOrClass name `thenRn` \ rn ->
- checkIEAbs rn `thenRn` \ exps ->
- returnRn (Nothing, exps)
- where
- checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag)
- checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag)
- checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag)
- checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag)
- checkIEAbs rn = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $
- returnRn (emptyBag, emptyBag)
-
-rnIE mods (IEThingAll name)
- = lookupTyConOrClass name `thenRn` \ rn ->
- checkIEAll rn `thenRn` \ exps ->
- checkImportAll rn `thenRn_`
- returnRn (Nothing, exps)
- where
- checkIEAll (RnData n cons fields)
- = returnRn (unitBag (exp_all n),
- listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields))
-
- checkIEAll (WiredInTyCon t)
- = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons))
- where
- cons = map getName (tyConDataCons t)
-
- checkIEAll (RnClass n ops)
- = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
- checkIEAll rn@(RnSyn n)
- = getSrcLocRn `thenRn` \ src_loc ->
- warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
- (synAllExportErr False{-warning-} rn src_loc)
-
- checkIEAll rn = pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
- returnRn (emptyBag, emptyBag)
-
- exp_all n = (n, ExportAll)
-
-rnIE mods (IEThingWith name names)
- = lookupTyConOrClass name `thenRn` \ rn ->
- mapRn lookupValue names `thenRn` \ rns ->
- checkIEWith rn rns `thenRn` \ exps ->
- checkImportAll rn `thenRn_`
- returnRn (Nothing, exps)