import RnMonad
import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn )
+ lubExportFlag, qualNameErr, dupNamesErr
+ )
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude )
-import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine )
+import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
)
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude, pRELUDE )
+import PrelMods ( fromPrelude, pRELUDE, rATIO, iX )
import Pretty
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import TyCon ( tyConDataCons )
Just exp -> exp
Nothing -> exp_fn n
- n = mkTopLevName uniq orig locn exp (occ_fn n)
+ n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s
in
- addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_`
addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
returnRn n
\end{code}
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,
- errs, imp_warns `unionBags` warns)
+ imp_errs `unionBags` errs,
+ imp_warns `unionBags` warns)
where
- (src_qprels, ok_imps) = partition qual_prel src_imps
- the_imps = ok_imps ++ prel_imp
- all_imps = the_imps ++ qprel_imp
+ the_imps = implicit_prel ++ src_imps
+ all_imps = implicit_qprel ++ the_imps
- qual_prel (ImportDecl mod qual imp_as _ _)
- = fromPrelude mod && qual && not (maybeToBool imp_as)
+ implicit_qprel = if opt_NoImplicitPrelude
+ then [{- no "import qualified Prelude" -}]
+ else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
- explicit_prelude_import
- = null [() | (ImportDecl mod qual _ _ _) <- ok_imps, fromPrelude mod]
+ explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
+ mod == pRELUDE ])
- qprel_imp = if opt_NoImplicitPrelude
- then [{-the flag really means it: *NO* implicit "import Prelude" -}]
- else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
-
- prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude
- then
- [{- no "import Prelude" -}]
- else
- [ImportDecl pRELUDE False Nothing Nothing prel_loc]
+ 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 src_qprels)
+ 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)
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 iface_cache mod >>= \ maybe_iface ->
+ = cachedIface False iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
Failed err ->
return (emptyBag, emptyBag, emptyBag, emptyBag,
>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->
- accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals))
+ 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
- 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
-
unquals = if qual then emptyBag
else mapBag pair_as (ie_vals `unionBags` ie_tcs)
getBuiltins _ mod maybe_spec
- | not (fromPrelude mod)
+ | not ((fromPrelude mod) || mod == iX || mod == rATIO )
= (emptyBag, emptyBag, maybe_spec)
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
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
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,rn):rest)
+ 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) of -- NB: we favour the tycon/class FM...
+ 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)
(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) of
+ case (lookupFM b_val_names (str,mod)) of
Nothing -> (vals, tcs, ie:ies_left)
Just rn -> case (ie,rn) of
(IEVar _, WiredInId _)
(vals, tcs, ies_left) = do_builtin ies
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
= (map mkAllIE (eltsFM exps), [], emptyBag)
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
= (map mkAllIE (eltsFM exps_left), found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
= (map fst found_ies, found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
Succeeded decl -> return (do_decl decl)
-getFixityDecl iface_cache rn
+getFixityDecl iface_cache (_,rn)
= let
(mod, str) = moduleNamePair rn
in
- cachedIface iface_cache mod >>= \ maybe_iface ->
+ cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
Failed err ->
return (Nothing, unitBag err)
- Succeeded (ParsedIface _ _ _ _ _ _ fixes _ _ _ _) ->
+ Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
case lookupFM fixes str of
Nothing -> return (Nothing, emptyBag)
Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
(imp_flag, imp_locs) = imp_fn n
- n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n)
+ n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s
in
returnRn n
\end{code}
message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
- ppBesides [pp_descrip rn, pprNonSym sty rn]) sty
+ ppCat [pp_descrip rn, pprNonSym sty rn]) sty
get_loc rn = case getImpLocs rn of
[] -> getSrcLoc rn
locs -> head locs
- pp_descrip (RnName _) = ppStr "a value"
- pp_descrip (RnSyn _) = ppStr "a type synonym"
- pp_descrip (RnData _ _ _) = ppStr "a data type"
- pp_descrip (RnConstr _ _) = ppStr "a data constructor"
- pp_descrip (RnField _ _) = ppStr "a record field"
- pp_descrip (RnClass _ _) = ppStr "a class"
- pp_descrip (RnClassOp _ _) = ppStr "a class method"
+ pp_descrip (RnName _) = ppStr "as a value:"
+ pp_descrip (RnSyn _) = ppStr "as a type synonym:"
+ pp_descrip (RnData _ _ _) = ppStr "as a data type:"
+ pp_descrip (RnConstr _ _) = ppStr "as a data constructor:"
+ pp_descrip (RnField _ _) = ppStr "as a record field:"
+ pp_descrip (RnClass _ _) = ppStr "as a class:"
+ pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
pp_descrip _ = ppNil
dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
= ppAboves (item1 : map dup_item dup_imps)
where
- item1 = addShortErrLocLine locn1 (\ sty ->
+ item1 = addShortWarnLocLine locn1 (\ sty ->
ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
dup_item (ImportDecl m _ _ _ locn)
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppCat [ppStr "here was another import from module", ppPStr m]) sty
qualPreludeImportWarn (ImportDecl m _ _ _ locn)
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppCat [ppStr "qualified import of prelude module", ppPStr m])
+dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
+ = ppAboves (item1 : map dup_item dup_quals)
+ where
+ item1 = addShortErrLocLine locn1 (\ sty ->
+ ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
+
+ dup_item (q,ImportDecl _ _ _ _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
+
unknownImpSpecErr ie imp_mod locn
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
allWhenSynImpSpecWarn n imp_mod locn
- = addShortErrLocLine locn (\ sty ->
+ = addShortWarnLocLine locn (\ sty ->
ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
allWhenAbsImpSpecErr n imp_mod locn
projects / ghc-hetmet.git / blobdiff