GlobalNameInfo(..)
) where
-import PreludeGlaST ( returnPrimIO, thenPrimIO, MutableVar(..) )
+import PreludeGlaST ( MutableVar(..) )
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
-import RnIfaces ( IfaceCache(..), cacheInterface, ParsedIface )
-import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupNamesErr )
-
-import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
-import ErrUtils ( Error(..), Warning(..), addShortErrLocLine )
-import FiniteMap ( fmToList )
-import Name ( RdrName(..), Name, isQual, mkTopLevName,
- mkImportedName, nameExportFlag,
- getLocalName, getSrcLoc, pprNonOp
+import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
+import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
+ lubExportFlag, qualNameErr, dupNamesErr
+ )
+import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
+
+
+import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
+ unionManyBags, mapBag, filterBag, listToBag, bagToList )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude )
+import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
+import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
+import Id ( GenId )
+import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
+import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
+ mkImportedName, nameExportFlag, nameImportFlag,
+ getLocalName, getSrcLoc, getImpLocs, moduleNamePair,
+ pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
)
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude )
+import PrelMods ( fromPrelude, pRELUDE_BUILTIN, pRELUDE, rATIO, iX )
import Pretty
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
+import TyCon ( tyConDataCons )
+import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( equivClasses, panic )
+import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
+ equivClasses, panic, assertPanic, pprTrace{-ToDo:rm-}
+ )
\end{code}
\begin{code}
type GlobalNameInfo = (BuiltinNames,
BuiltinKeys,
- Name -> ExportFlag,
- Name -> [RdrName])
+ Name -> ExportFlag, -- export flag
+ Name -> [RdrName]) -- occurence names
type RnM_Info s r = RnMonad GlobalNameInfo s r
-> GlobalNameInfo
-> UniqSupply
-> RdrNameHsModule
- -> PrimIO (RnEnv,
- [Module],
- Bag RenamedFixityDecl,
- Bag Error,
- Bag Warning)
-
-getGlobalNames iface_var info us
+ -> IO (RnEnv,
+ [Module], -- directly imported modules
+ Bag (Module,RnName), -- unqualified imports from module
+ Bag RenamedFixityDecl, -- imported fixity decls
+ Bag Error,
+ Bag Warning)
+
+getGlobalNames iface_cache info us
(HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
= case initRn True mod emptyRnEnv us1
(setExtraRn info $
getSourceNames ty_decls cls_decls binds)
of { ((src_vals, src_tcs), src_errs, src_warns) ->
- getImportedNames iface_var info us2 imports `thenPrimIO`
- \ (imp_vals, imp_tcs, imp_mods, imp_fixes, imp_errs, imp_warns) ->
+ doImportDecls iface_cache info us2 imports >>=
+ \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
let
- unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
- unqual_tcs = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs
+ unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
+ unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
- all_vals = bagToList (unqual_vals `unionBags` imp_vals)
- all_tcs = bagToList (unqual_tcs `unionBags` imp_tcs)
+ (src_env, src_dups) = extendGlobalRnEnv emptyRnEnv unqual_vals unqual_tcs
+ (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
- (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
+ -- remove dups of the same imported thing
+ diff_imp_dups = filterBag diff_orig imp_dups
+ diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2
- dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
+ all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
+ dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
- dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
+ dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
- all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
+ all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
- returnPrimIO (all_env, bagToList imp_mods, imp_fixes, all_errs, all_warns)
+ return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
}
where
(us1, us2) = splitUniqSupply us
Bag RnName) -- tycons/classes
getSourceNames ty_decls cls_decls binds
- = mapAndUnzipRn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s) ->
- mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
- getTopBindsNames binds `thenRn` \ bind_names ->
+ = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) ->
+ mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
+ getTopBindsNames binds `thenRn` \ bind_names ->
returnRn (unionManyBags constrs_s `unionBags`
+ unionManyBags fields_s `unionBags`
unionManyBags cls_ops_s `unionBags` bind_names,
listToBag tycon_s `unionBags` listToBag cls_s)
getTyDeclNames :: RdrNameTyDecl
- -> RnM_Info s (RnName, Bag RnName) -- tycon and constrs
+ -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
- condecls `thenRn` \ con_names ->
- returnRn (RnData tycon_name con_names,
- listToBag (map (\ n -> RnConstr n tycon_name) con_names))
-
-getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
- condecls `thenRn` \ con_names ->
- returnRn (RnData tycon_name con_names,
- listToBag (map (\ n -> RnConstr n tycon_name) con_names))
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
+ condecls `thenRn` \ (con_names, field_names) ->
+ let
+ rn_tycon = RnData tycon_name con_names field_names
+ rn_constrs = [ RnConstr name tycon_name | name <- con_names]
+ rn_fields = [ RnField name tycon_name | name <- field_names]
+ in
+ returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
+
+getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
+ `thenRn` \ con_name ->
+ returnRn (RnData tycon_name [con_name] [],
+ unitBag (RnConstr con_name tycon_name),
+ emptyBag)
getTyDeclNames (TySynonym tycon _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- returnRn (RnSyn tycon_name, emptyBag)
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ returnRn (RnSyn tycon_name, emptyBag, emptyBag)
-getConDeclName exp (ConDecl con _ src_loc)
- = newGlobalName src_loc exp con
-getConDeclName exp (ConOpDecl _ op _ src_loc)
- = newGlobalName src_loc exp op
-getConDeclName exp (NewConDecl con _ src_loc)
- = newGlobalName src_loc exp con
-getConDeclName exp (RecConDecl con fields src_loc)
- = panic "getConDeclName:RecConDecl"
- newGlobalName src_loc exp con
+getConFieldNames exp constrs fields have []
+ = returnRn (bagToList constrs, bagToList fields)
+
+getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
+ getConFieldNames exp (constrs `snocBag` con_name) fields have rest
+
+getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
+ getConFieldNames exp (constrs `snocBag` con_name) fields have rest
+
+getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
+ = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
+ newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
+ mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
+ let
+ all_constrs = constrs `snocBag` con_name
+ all_fields = fields `unionBags` listToBag field_names
+ in
+ getConFieldNames exp all_constrs all_fields new_have rest
+ where
+ (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
+ new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
+ new_have = addListToFM have (zip new_fields (repeat ()))
getClassNames :: RdrNameClassDecl
-> RnM_Info s (RnName, Bag RnName) -- class and class ops
getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
- = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
+ = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
getClassOpNames (Just (nameExportFlag class_name))
sigs `thenRn` \ op_names ->
returnRn (RnClass class_name op_names,
getClassOpNames exp []
= returnRn []
getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp op `thenRn` \ op_name ->
+ = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
getClassOpNames exp sigs `thenRn` \ op_names ->
returnRn (op_name : op_names)
getClassOpNames exp (_ : sigs)
doField locn (_, pat, _) = doPat locn pat
doName locn rdr
- = newGlobalName locn Nothing rdr `thenRn` \ name ->
+ = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
returnRn (unitBag (RnName name))
\end{code}
*********************************************************
\begin{code}
-newGlobalName :: SrcLoc -> Maybe ExportFlag
+newGlobalName :: SrcLoc -> Maybe ExportFlag -> Bool{-True<=>value name,False<=>tycon/class-}
-> RdrName -> RnM_Info s Name
-newGlobalName locn maybe_exp rdr
- = getExtraRn `thenRn` \ (_,_,exp_fn,occ_fn) ->
+-- ToDo: b_names and b_keys being defined in this module !!!
+
+newGlobalName locn maybe_exp is_val_name rdr
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,exp_fn,occ_fn) ->
getModuleRn `thenRn` \ mod ->
- getSourceRn `thenRn` \ source ->
rnGetUnique `thenRn` \ u ->
let
- src_unqual = getLocalName rdr
-
- src_orig = if fromPrelude mod
- then (Unqual src_unqual)
- else (Qual mod src_unqual)
+ unqual = case rdr of { Qual m n -> n; Unqual n -> n }
+
+ orig = if fromPrelude mod
+ then (Unqual unqual)
+ else (Qual mod unqual)
+
+ uniq
+ = let
+ str_mod = case orig of { Qual m n -> (n, m); Unqual n -> (n, pRELUDE) }
+ n = fst str_mod
+ m = snd str_mod
+ in
+ --pprTrace "newGlobalName:" (ppAboves ((ppCat [ppPStr n, ppPStr m]) : [ ppCat [ppPStr x, ppPStr y] | (x,y) <- keysFM b_keys])) $
+ case (lookupFM b_keys str_mod) of
+ Just (key,_) -> key
+ Nothing -> if not opt_CompilingPrelude then u else
+ case (lookupFM (if is_val_name then b_val_names else b_tc_names) str_mod) of
+ Nothing -> u
+ Just xx -> --pprTrace "Using Unique for:" (ppCat [ppPStr n, ppPStr m]) $
+ uniqueOf xx
exp = case maybe_exp of
Just exp -> exp
Nothing -> exp_fn n
- n = if source then
- mkTopLevName u src_orig locn exp (occ_fn n)
- else
- mkImportedName u rdr locn exp (occ_fn n)
+ n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s
in
- addErrIfRn (source && isQual rdr)
- (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
+ addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
returnRn n
\end{code}
*********************************************************
\begin{code}
-getImportedNames ::
+type ImportNameInfo = (GlobalNameInfo,
+ FiniteMap (Module,FAST_STRING) RnName, -- values imported so far
+ FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far
+ Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns
+
+type RnM_IInfo s r = RnMonad ImportNameInfo s r
+
+doImportDecls ::
IfaceCache
-> GlobalNameInfo -- builtin and knot name info
-> UniqSupply
-> [RdrNameImportDecl] -- import declarations
- -> PrimIO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- Bag Module, -- directly imported modules
- Bag RenamedFixityDecl, -- fixity info for imported names
- Bag Error,
- Bag Warning)
-
-getImportedNames iface_var info us imports
- = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag)
+ -> 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
+ -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
+ 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" -}
+ ImportDecl pRELUDE_BUILTIN True Nothing Nothing prel_loc
+ ]
+ 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" -}
+ ImportDecl pRELUDE_BUILTIN False Nothing Nothing prel_loc
+ ]
+ 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, mod /= pRELUDE_BUILTIN ]
+
+ 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)
+ = let
+ (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
+ in
+ (if mod == pRELUDE_BUILTIN then
+ return (Succeeded (panic "doImport:PreludeBuiltin"),
+ \ iface -> ([], [], emptyBag))
+ else
+ --pprTrace "doImport:" (ppPStr mod) $
+ cachedIface False iface_cache 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 == pRELUDE_BUILTIN then
+ return [ (Nothing, emptyBag) | _ <- final_vals_list ]
+ else
+ accumulate (map (getFixityDecl iface_cache) 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 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
- -- For now jsut add the builtin names ...
- (b_names,_,_,_) = info
- builtin_vals = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, not (isRnTyCon rn)]
- builtin_tcs = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, isRnTyCon rn]
+ 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)
+ 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
+ = (map fst found_ies, found_ies, errs)
+ where
+ (found_ies, errs) = lookupIEs exps ies
+
+
+mkAllIE (orig,ExportAbs)
+ = ASSERT(isLexCon (getLocalName orig))
+ IEThingAbs orig
+mkAllIE (orig, ExportAll)
+ | isLexCon (getLocalName orig)
+ = IEThingAll orig
+ | otherwise
+ = IEVar orig
+
+
+lookupIEs exps []
+ = ([], emptyBag)
+lookupIEs exps (ie:ies)
+ = case lookupFM exps (unqual_str (ie_name ie)) of
+ Nothing ->
+ (orig_ies, unknownImpSpecErr ie `consBag` errs)
+ Just (orig,flag) ->
+ (orig_ie orig flag ie ++ orig_ies,
+ adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs)
+ where
+ (orig_ies, errs) = lookupIEs exps ies
+
+ orig_ie orig flag (IEVar n) = [(IEVar orig, flag)]
+ orig_ie orig flag (IEThingAbs n) = [(IEThingAbs orig, flag)]
+ orig_ie orig flag (IEThingAll n) = [(IEThingAll orig, flag)]
+ orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)]
+
+ seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
+
+
+doOrigIEs iface_cache info mod src_loc us []
+ = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
+
+doOrigIEs iface_cache info mod src_loc us (ie:ies)
+ = doOrigIE iface_cache info mod src_loc us1 ie
+ >>= \ (vals1, tcs1, imps1, errs1, warns1) ->
+ doOrigIEs iface_cache info mod src_loc us2 ies
+ >>= \ (vals2, tcs2, imps2, errs2, warns2) ->
+ return (vals1 `unionBags` vals2,
+ tcs1 `unionBags` tcs2,
+ imps1 `unionBags` imps2,
+ errs1 `unionBags` errs2,
+ warns1 `unionBags` warns2)
+ where
+ (us1, us2) = splitUniqSupply us
+
+doOrigIE iface_cache info mod src_loc us ie
+ = with_decl iface_cache (ie_name ie)
+ (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag))
+ (\ decl -> case initRn True mod emptyRnEnv us
+ (setExtraRn info $
+ pushSrcLocRn src_loc $
+ getIfaceDeclNames ie decl)
+ of
+ ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
+
+checkOrigIE iface_cache (IEThingAll n, ExportAbs)
+ = with_decl iface_cache n
+ (\ err -> (unitBag (\ mod locn -> err), emptyBag))
+ (\ decl -> case decl of
+ TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n))
+ other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
+
+checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
+ = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
+
+checkOrigIE iface_cache (IEThingWith n ns, ExportAll)
+ = with_decl iface_cache n
+ (\ err -> (unitBag (\ mod locn -> err), emptyBag))
+ (\ decl -> case decl of
+ NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
+ DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
+ ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
+ where
+ check_with str has rdrs
+ | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs)
+ = emptyBag
+ | otherwise
+ = unitBag (withImpSpecErr str n has rdrs)
+
+checkOrigIE iface_cache other
+ = return (emptyBag, emptyBag)
+
+
+with_decl iface_cache n do_err do_decl
+ = cachedDecl iface_cache (isRdrLexCon n) n >>= \ maybe_decl ->
+ case maybe_decl of
+ Failed err -> return (do_err err)
+ Succeeded decl -> return (do_decl decl)
+
+
+getFixityDecl iface_cache (_,rn)
+ = let
+ (mod, str) = moduleNamePair rn
+
+ succeeded infx i = return (Just (infx rn i), emptyBag)
+ in
+ cachedIface True iface_cache mod >>= \ maybe_iface ->
+ case maybe_iface of
+ Failed err ->
+ return (Nothing, unitBag err)
+ Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
+ case lookupFM fixes str of
+ Nothing -> return (Nothing, emptyBag)
+ Just (InfixL _ i) -> succeeded InfixL i
+ Just (InfixR _ i) -> succeeded InfixR i
+ Just (InfixN _ i) -> succeeded InfixN i
+
+ie_name (IEVar n) = n
+ie_name (IEThingAbs n) = n
+ie_name (IEThingAll n) = n
+ie_name (IEThingWith n _) = n
+
+unqual_str (Unqual str) = str
+unqual_str q@(Qual _ _) = panic "unqual_str"
+
+adderr_if True err errs = err `consBag` errs
+adderr_if False err errs = errs
\end{code}
+*********************************************************
+* *
+\subsection{Actually creating the imported names}
+* *
+*********************************************************
+
+\begin{code}
+getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl
+ -> RnM_IInfo s (Bag RnName, -- values
+ Bag RnName, -- tycons/classes
+ Bag (RnName,ExportFlag)) -- import flags
+
+getIfaceDeclNames ie (ValSig val src_loc _)
+ = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
+ returnRn (unitBag (RnName val_name),
+ emptyBag,
+ unitBag (RnName val_name, ExportAll))
+
+getIfaceDeclNames ie (TypeSig tycon src_loc _)
+ = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
+ returnRn (emptyBag,
+ unitBag (RnSyn tycon_name),
+ unitBag (RnSyn tycon_name, ExportAll))
+
+getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
+ = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
+ newImportedName False src_loc (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name))
+ con `thenRn` \ con_name ->
+ returnRn (if imp_all (imp_flag ie) then
+ unitBag (RnConstr con_name tycon_name)
+ else
+ emptyBag,
+ unitBag (RnData tycon_name [con_name] []),
+ unitBag (RnData tycon_name [con_name] [], imp_flag ie))
+
+getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
+ = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
+ let
+ map_me = mapRn (newImportedName False src_loc
+ (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name)))
+ in
+ map_me cons `thenRn` \ con_names ->
+ map_me fields `thenRn` \ field_names ->
+ let
+ rn_tycon = RnData tycon_name con_names field_names
+ rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
+ rn_fields = [ RnField name tycon_name | name <- field_names ]
+ in
+ returnRn (if imp_all (imp_flag ie) then
+ listToBag rn_constrs `unionBags` listToBag rn_fields
+ else
+ emptyBag,
+ unitBag rn_tycon,
+ unitBag (rn_tycon, imp_flag ie))
+
+getIfaceDeclNames ie (ClassSig cls ops src_loc _)
+ = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
+ mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
+ (Just (nameImportFlag cls_name)))
+ ops `thenRn` \ op_names ->
+ returnRn (if imp_all (imp_flag ie) then
+ listToBag (map (\ n -> RnClassOp n cls_name) op_names)
+ else
+ emptyBag,
+ unitBag (RnClass cls_name op_names),
+ unitBag (RnClass cls_name op_names, imp_flag ie))
+
+
+imp_all ExportAll = True
+imp_all _ = False
+
+imp_flag (IEThingAbs _) = ExportAbs
+imp_flag (IEThingAll _) = ExportAll
+imp_flag (IEThingWith _ _) = ExportAll
+\end{code}
+
+*********************************************************
+* *
+\subsection{Creating a new imported name}
+* *
+*********************************************************
+
+\begin{code}
+newImportedName :: Bool -- True => tycon or class
+ -> SrcLoc
+ -> Maybe ExportFlag -- maybe export flag
+ -> Maybe ExportFlag -- maybe import flag
+ -> RdrName -- orig name
+ -> RnM_IInfo s Name
+
+newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
+ = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) ->
+ case if tycon_or_class
+ then lookupFM done_tcs (moduleNamePair rdr)
+ else lookupFM done_vals (moduleNamePair rdr)
+ of
+ Just rn -> returnRn (getName rn)
+ Nothing ->
+ rnGetUnique `thenRn` \ u ->
+ let
+ str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n,pRELUDE) }
+
+ uniq = case lookupFM b_keys str_mod of
+ Nothing -> u
+ Just (key,_) -> key
+
+ exp = case maybe_exp of
+ Just exp -> exp
+ Nothing -> exp_fn n
+
+ imp = case maybe_imp of
+ Just imp -> imp
+ Nothing -> imp_flag
+
+ (imp_flag, imp_locs) = imp_fn n
+
+ n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s
+ in
+ returnRn n
+\end{code}
\begin{code}
globalDupNamesErr rdr rns sty
- = ppHang (ppBesides [pprNonOp sty rdr, ppStr " multiply defined:"])
- 4 (ppAboves (map pp_def rns))
+ = ppAboves (message : map pp_dup rns)
+ where
+ message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
+
+ pp_dup rn = addShortErrLocLine (get_loc 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 "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
- pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
+ item1 = addShortWarnLocLine locn1 (\ sty ->
+ ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
+
+ dup_item (ImportDecl m _ _ _ locn)
+ = addShortWarnLocLine locn (\ sty ->
+ ppCat [ppStr "here was another import from module", ppPStr m]) sty
- -- ToDo: print import src locs for imported names
+qualPreludeImportWarn (ImportDecl m _ _ _ locn)
+ = 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 "'"])
+
+duplicateImpSpecErr ie imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
+
+allWhenSynImpSpecWarn n imp_mod locn
+ = addShortWarnLocLine locn (\ sty ->
+ ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
+
+allWhenAbsImpSpecErr n imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
+
+withWhenAbsImpSpecErr n imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
+
+withImpSpecErr str n has ns imp_mod locn
+ = addErrLoc locn "" (\ sty ->
+ ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
+ ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
+ ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ])
+
+dupFieldErr con locn (dup:rest)
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])
\end{code}
projects / ghc-hetmet.git / blobdiff