+ -> [RdrNameImportDecl] -- import declarations
+ -> IO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ [Module], -- directly imported modules
+ Bag (Module,RnName), -- unqualified import from module
+ Bag RenamedFixityDecl, -- fixity info for imported names
+ Bag Error,
+ Bag Warning)
+
+doImportDecls iface_cache g_info us src_imps
+ = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
+ let
+ rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
+ add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
+
+ rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
+ rec_imp_fn n = case lookupUFM rec_imp_fm n of
+ Nothing -> panic "RnNames:rec_imp_fn"
+ Just (flag, locns) -> (flag, bagToList locns)
+
+ i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
+ in
+ -- cache the imported modules
+ -- this ensures that all directly imported modules
+ -- will have their original name iface in scope
+ accumulate (map (cachedIface False iface_cache) imp_mods) >>
+
+ -- process the imports
+ doImports iface_cache i_info us all_imps
+
+ ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
+
+ return (vals, tcs, imp_mods, unquals, fixes,
+ imp_errs `unionBags` errs,
+ imp_warns `unionBags` warns)
+ where
+ the_imps = implicit_prel ++ src_imps
+ all_imps = implicit_qprel ++ the_imps
+
+ implicit_qprel = if opt_NoImplicitPrelude
+ then [{- no "import qualified Prelude" -}]
+ else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
+
+ explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
+ mod == pRELUDE ])
+
+ implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude
+ then [{- no "import Prelude" -}]
+ else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
+
+ prel_loc = mkBuiltinSrcLoc
+
+ (uniq_imps, imp_dups) = removeDups cmp_mod the_imps
+ cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
+
+ qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
+ fromPrelude mod ]
+
+ qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
+ qual_name mod (Just as_mod) = as_mod
+ qual_name mod Nothing = mod
+
+ (_, qual_dups) = removeDups cmp_qual qual_mods
+ bad_qual_dups = filter (not . all_same_mod) qual_dups
+
+ cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
+ all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
+ = all has_same_mod rest
+ where
+ has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2
+
+
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+
+ imp_warns = listToBag (map dupImportWarn imp_dups)
+ `unionBags`
+ listToBag (map qualPreludeImportWarn qprel_imps)
+
+ imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
+
+doImports iface_cache i_info us []
+ = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
+doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps)
+ = doImport iface_cache i_info us1 imp
+ >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
+ let
+ new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1,
+ not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ]
+ -- moduleNamePair computed twice
+ ext_vals = addListToFM done_vals new_vals
+
+ new_tcs = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1,
+ not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ]
+ ext_tcs = addListToFM done_tcs new_tcs
+ in
+ doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps
+ >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
+ return (vals1 `unionBags` vals2,
+ tcs1 `unionBags` tcs2,
+ unquals1 `unionBags` unquals2,
+ fixes1 `unionBags` fixes2,
+ errs1 `unionBags` errs2,
+ warns1 `unionBags` warns2,
+ imps1 `unionBags` imps2)
+ where
+ (us1, us2) = splitUniqSupply us
+
+
+doImport :: IfaceCache
+ -> ImportNameInfo
+ -> UniqSupply
+ -> RdrNameImportDecl
+ -> IO (Bag (RdrName,RnName), -- values
+ Bag (RdrName,RnName), -- tycons/classes
+ Bag (Module,RnName), -- unqual imports
+ Bag RenamedFixityDecl,
+ Bag Error,
+ Bag Warning,
+ Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
+
+doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
+ = cachedIface False iface_cache mod >>= \ maybe_iface ->
+ case maybe_iface of
+ Failed err ->
+ return (emptyBag, emptyBag, emptyBag, emptyBag,
+ unitBag err, emptyBag, emptyBag)
+ Succeeded iface ->
+ let
+ (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
+ (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec'
+ in
+ doOrigIEs iface_cache info mod src_loc us ies
+ >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
+ accumulate (map (checkOrigIE iface_cache) chk_ies)
+ >>= \ chk_errs_warns ->
+ let
+ final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
+ final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
+ in
+ accumulate (map (getFixityDecl iface_cache) (bagToList final_vals))
+ >>= \ fix_maybes_errs ->
+ let
+ (chk_errs, chk_warns) = unzip chk_errs_warns
+ (fix_maybes, fix_errs) = unzip fix_maybes_errs
+
+ unquals = if qual then emptyBag
+ else mapBag pair_as (ie_vals `unionBags` ie_tcs)
+
+ final_fixes = listToBag (catMaybes fix_maybes)
+
+ final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
+ `unionBags` errs `unionBags` unionManyBags fix_errs
+ final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
+ `unionBags` warns
+ imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
+ in
+ return (final_vals, final_tcs, unquals, final_fixes,
+ final_errs, final_warns, imp_stuff)
+ where
+ as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
+ mk_occ str = if qual then Qual as_mod str else Unqual str
+
+ fst_occ (str, rn) = (mk_occ str, rn)
+ pair_occ rn = (mk_occ (getLocalName rn), rn)
+ pair_as rn = (as_mod, rn)
+
+
+getBuiltins _ mod maybe_spec
+ | not ((fromPrelude mod) || mod == iX || mod == rATIO )
+ = (emptyBag, emptyBag, maybe_spec)
+
+getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
+ = case maybe_spec of
+ Nothing -> (all_vals, all_tcs, Nothing)
+
+ Just (True, ies) -> -- hiding does not work for builtin names
+ trace "getBuiltins: import Prelude hiding ( ... )" $
+ (all_vals, all_tcs, maybe_spec)
+
+ Just (False, ies) -> let
+ (vals,tcs,ies_left) = do_builtin ies
+ in
+ (vals, tcs, Just (False, ies_left))
+ where
+ all_vals = do_all_builtin (fmToList b_val_names)
+ all_tcs = do_all_builtin (fmToList b_tc_names)
+
+ filter_mod = if fromPrelude mod then pRELUDE else mod
+
+ do_all_builtin [] = emptyBag
+ do_all_builtin (((str,mod),rn):rest)
+ | mod == filter_mod
+ = (str, rn) `consBag` do_all_builtin rest
+ | otherwise
+ = do_all_builtin rest
+
+ do_builtin [] = (emptyBag,emptyBag,[])
+ do_builtin (ie:ies)
+ = let str = unqual_str (ie_name ie)
+ in
+ case (lookupFM b_tc_names (str,mod)) of -- NB: we favour the tycon/class FM...
+ Just rn -> case (ie,rn) of
+ (IEThingAbs _, WiredInTyCon tc)
+ -> (vals, (str, rn) `consBag` tcs, ies_left)
+ (IEThingAll _, WiredInTyCon tc)
+ -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
+ (tyConDataCons tc))
+ `unionBags` vals,
+ (str,rn) `consBag` tcs, ies_left)
+ (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
+ -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
+ (tyConDataCons tc))
+ `unionBags` vals,
+ (str,rn) `consBag` tcs, ies_left)
+ _ -> panic "importing builtin names (1)"
+
+ Nothing ->
+ case (lookupFM b_val_names (str,mod)) of
+ Nothing -> (vals, tcs, ie:ies_left)
+ Just rn -> case (ie,rn) of
+ (IEVar _, WiredInId _)
+ -> ((str, rn) `consBag` vals, tcs, ies_left)
+ _ -> panic "importing builtin names (2)"
+ where
+ (vals, tcs, ies_left) = do_builtin ies
+
+
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
+ = (map mkAllIE (eltsFM exps), [], emptyBag)
+
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
+ = (map mkAllIE (eltsFM exps_left), found_ies, errs)