+ trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
+ trashed_imports = {-trace "rnSource:trashed_imports"-} []
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Export list}
+%* *
+%*********************************************************
+
+\begin{code}
+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)
+ where
+ checkIEWith rn@(RnData n cons fields) rns
+ | same_names (cons++fields) rns
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
+ `unionBags`
+ listToBag (map exp_all fields))
+ | otherwise
+ = rnWithErr "constructors (and fields)" rn (cons++fields) rns
+ checkIEWith rn@(RnClass n ops) rns
+ | same_names ops rns
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
+ | otherwise
+ = rnWithErr "class ops" rn ops rns
+ checkIEWith rn@(RnSyn _) rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
+ checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)"
+ checkIEWith rn rns
+ = pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
+ returnRn (emptyBag, emptyBag)
+
+ exp_all n = (n, ExportAll)
+
+ same_names has rns
+ = all (not.isRnUnbound) rns &&
+ sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
+
+ rnWithErr str rn has rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
+
+rnIE mods (IEModuleContents mod)
+ | isIn "rnIE:IEModule" mod mods
+ = returnRn (Just mod, (emptyBag, emptyBag))
+ | otherwise
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
+
+
+checkImportAll rn
+ = case nameImportFlag (getName rn) of
+ ExportAll -> returnRn ()
+ exp -> getSrcLocRn `thenRn` \ src_loc ->
+ addErrRn (importAllErr rn src_loc)