- add_new_one fm (_, rn)
- = let
- orig = origName "add_new_one" rn
- in
- case (lookupFM fm orig) of
- Just _ -> fm -- already there: no change
- Nothing -> addToFM fm orig rn
-
-----------------------
-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)
- = let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec -- NB: a no-op ToDo:rm
- in
- (if mod == gHC_BUILTINS then
- return (Succeeded (panic "doImport:GHC fake import!"),
- \ iface -> ([], [], emptyBag))
- else
- --pprTrace "doImport:" (ppPStr mod) $
- cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
- return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
- ) >>= \ (maybe_iface, do_ies) ->
-
- case maybe_iface of
- Failed err ->
- return (emptyBag, emptyBag, emptyBag, emptyBag,
- unitBag err, emptyBag, emptyBag)
- Succeeded iface ->
- let
- (ies, chk_ies, get_errs) = do_ies iface
- 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
- final_vals_list = bagToList final_vals
- in
- (if mod == gHC_BUILTINS then
- return [ (Nothing, emptyBag) | _ <- final_vals_list ]
- else
- accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
- ) >>= \ fix_maybes_errs ->
- let
- (chk_errs, chk_warns) = unzip chk_errs_warns
- (fix_maybes, fix_errs) = unzip fix_maybes_errs
-
- unquals = if qual{-ified import-}
- 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 :: Module
- as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
-
- mk_occ :: FAST_STRING -> RdrName
- mk_occ str = if qual then Qual as_mod str else Unqual str
-
- fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
- fst_occ (str, rn) = (mk_occ str, rn)
-
- pair_occ :: RnName -> (RdrName, RnName)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
-
- pair_as :: RnName -> (Module, RnName)
- pair_as rn = (as_mod, rn)
-
------------------------------
-getBuiltins :: ImportNameInfo
- -> Module
- -> Maybe (Bool, [RdrNameIE])
- -> (Bag (FAST_STRING, RnName),
- Bag (FAST_STRING, RnName),
- Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
- )
-
-getBuiltins _ modname maybe_spec
---OLD: | modname `notElem` modulesWithBuiltins
- = (emptyBag, emptyBag, maybe_spec)
-
-{-
-getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
- = case maybe_spec of
- Nothing -> (all_vals, all_tcs, Nothing)
-
- Just (True, ies) -> -- hiding does not work for builtin names
- trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
- (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)
-
- do_all_builtin [] = emptyBag
- do_all_builtin (((OrigName mod str),rn):rest)
- = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
- (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
-
- do_builtin [] = (emptyBag,emptyBag,[])
- do_builtin (ie:ies)
- = let
- (str, orig)
- = case (ie_name ie) of
- Unqual s -> (s, OrigName modname s)
- Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
- (s, OrigName modname s)
- in
- case (lookupFM b_tc_names orig) 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 -> (nameOf (origName "IEThingWith" id), WiredInId id))
- (tyConDataCons tc))
- `unionBags` vals,
- (str,rn) `consBag` tcs, ies_left)
- _ -> panic "importing builtin names (1)"
-
- Nothing ->
- case (lookupFM b_val_names orig) 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
--}