%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnNames]{Extracting imported and top-level names in scope}
\begin{code}
-#include "HsVersions.h"
-
module RnNames (
- getGlobalNames,
- SYN_IE(GlobalNameInfo)
+ getGlobalNames
) where
-import PreludeGlaST ( SYN_IE(MutableVar) )
-
-IMP_Ubiq()
+#include "HsVersions.h"
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
+import CmdLineOpts ( DynFlag(..) )
-import RnMonad
-import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
-import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
- )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
-
-
-import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
- unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
-import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals )
-import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, FiniteMap )
-import Id ( GenId )
-import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
-import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
- nameOf, qualToOrigName, mkImportedName,
- nameExportFlag, nameImportFlag,
- getLocalName, getSrcLoc, getImpLocs,
- moduleNamePair, pprNonSym,
- isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
+import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
+ collectTopBinders
)
-import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
-import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
-import Pretty
-import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
-import TyCon ( tyConDataCons )
-import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
+ RdrNameHsModule, RdrNameHsDecl
)
---import PprStyle --ToDo:rm
+import RnIfaces ( getInterfaceExports, recordLocalSlurps )
+import RnHiFiles ( getTyClDeclBinders )
+import RnEnv
+import RnMonad
+
+import FiniteMap
+import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR )
+import UniqFM ( lookupUFM )
+import Bag ( bagToList )
+import Module ( ModuleName, moduleName, WhereFrom(..) )
+import NameSet
+import Name ( Name, nameSrcLoc,
+ setLocalNameSort, nameOccName, nameEnvElts )
+import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
+ GenAvailInfo(..), AvailInfo, Avails, AvailEnv )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual )
+import OccName ( setOccNameSpace, dataName )
+import NameSet ( elemNameSet, emptyNameSet )
+import Outputable
+import Maybes ( maybeToBool, catMaybes, mapMaybe )
+import UniqFM ( emptyUFM, listToUFM )
+import ListSetOps ( removeDups )
+import Util ( sortLt )
+import List ( partition )
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Get global names}
+%* *
+%************************************************************************
+
\begin{code}
-type GlobalNameInfo = (BuiltinNames,
- BuiltinKeys,
- Name -> ExportFlag, -- export flag
- Name -> [RdrName]) -- occurrence names
- -- NB: both of the functions are in a *knot* and
- -- must be tugged on oh-so-gently...
-
-type RnM_Info s r = RnMonad GlobalNameInfo s r
-
-getGlobalNames ::
- IfaceCache
- -> GlobalNameInfo
- -> UniqSupply
- -> RdrNameHsModule
- -> 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 _ _)
- = let
- (us1, us2) = splitUniqSupply us
- in
- case initRn True mod emptyRnEnv us1
- (setExtraRn info $
- getSourceNames ty_decls cls_decls binds)
- of { ((src_vals, src_tcs), src_errs, src_warns) ->
+getGlobalNames :: Module -> RdrNameHsModule
+ -> RnMG (GlobalRdrEnv, -- Maps all in-scope things
+ GlobalRdrEnv, -- Maps just *local* things
+ Avails, -- The exported stuff
+ AvailEnv) -- Maps a name to its parent AvailInfo
+ -- Just for in-scope things only
+
+getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc)
+ = -- These two fix-loops are to get the right
+ -- provenance information into a Name
+ fixRn ( \ ~(rec_gbl_env, _, rec_export_avails, _) ->
- doImportDecls iface_cache info us2 imports >>=
- \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
+ let
+ rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
+ rec_unqual_fn = unQualInScope rec_gbl_env
- let
- unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
- unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
+ rec_exp_fn :: Name -> Bool
+ rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails)
+ in
- (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
- (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
+ -- PROCESS LOCAL DECLS
+ -- Do these *first* so that the correct provenance gets
+ -- into the global name cache.
+ importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
- -- remove dups of the same imported thing
- diff_imp_dups = filterBag diff_orig imp_dups
- diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
+ -- PROCESS IMPORT DECLS
+ -- Do the non {- SOURCE -} ones first, so that we get a helpful
+ -- warning for {- SOURCE -} ones that are unnecessary
+ doptRn Opt_NoImplicitPrelude `thenRn` \ opt_no_prelude ->
+ let
+ all_imports = mk_prel_imports opt_no_prelude ++ imports
+ (source, ordinary) = partition is_source_import all_imports
+ is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
+ is_source_import other = False
- 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,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
+ get_imports = importsFromImportDecl this_mod_name rec_unqual_fn
+ in
+ mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
+ mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
- all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
- all_warns = src_warns `unionBags` imp_warns
- in
--- pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
--- pprTrace "src_env:" (pprRnEnv PprDebug src_env) $
--- pprTrace "all_env:" (pprRnEnv PprDebug all_env) $
- return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
-\end{code}
+ -- COMBINE RESULTS
+ -- We put the local env second, so that a local provenance
+ -- "wins", even if a module imports itself.
+ let
+ gbl_env :: GlobalRdrEnv
+ imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1)
+ gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
-*********************************************************
-* *
-\subsection{Top-level source names}
-* *
-*********************************************************
+ all_avails :: ExportAvails
+ all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
+ (_, global_avail_env) = all_avails
+ in
+
+ -- PROCESS EXPORT LIST (but not if we've had errors already)
+ checkErrsRn `thenRn` \ no_errs_so_far ->
+ (if no_errs_so_far then
+ exportsFromAvail this_mod_name exports all_avails gbl_env
+ else
+ returnRn []
+ ) `thenRn` \ export_avails ->
+
+ -- ALL DONE
+ returnRn (gbl_env, local_gbl_env, export_avails, global_avail_env)
+ )
+ where
+ this_mod_name = moduleName this_mod
+
+ -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
+ -- because the former doesn't even look at Prelude.hi for instance declarations,
+ -- whereas the latter does.
+ mk_prel_imports no_prelude
+ | this_mod_name == pRELUDE_Name ||
+ explicit_prelude_import ||
+ no_prelude
+ = []
+
+ | otherwise = [ImportDecl pRELUDE_Name
+ ImportByUser
+ False {- Not qualified -}
+ Nothing {- No "as" -}
+ Nothing {- No import list -}
+ mod_loc]
+
+ explicit_prelude_import
+ = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ])
+\end{code}
+
\begin{code}
-getSourceNames :: -- Collects global *binders* (not uses)
- [RdrNameTyDecl]
- -> [RdrNameClassDecl]
- -> RdrNameHsBinds
- -> RnM_Info s (Bag RnName, -- values
- Bag RnName) -- tycons/classes
-
-getSourceNames ty_decls cls_decls binds
- = 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, Bag RnName) -- tycon, constrs and fields
-
-getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
- --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
- --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_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) ->
+importsFromImportDecl :: ModuleName
+ -> (Name -> Bool) -- OK to omit qualifier
+ -> RdrNameImportDecl
+ -> RnMG (GlobalRdrEnv,
+ ExportAvails)
+
+importsFromImportDecl this_mod_name is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
+ = pushSrcLocRn iloc $
+ getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails_by_module) ->
+
+ if null avails_by_module then
+ -- If there's an error in getInterfaceExports, (e.g. interface
+ -- file not found) we get lots of spurious errors from 'filterImports'
+ returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
+ else
+
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]
+ avails :: Avails
+ avails = [ avail | (mod_name, avails) <- avails_by_module,
+ mod_name /= this_mod_name,
+ avail <- avails ]
+ -- If the module exports anything defined in this module, just ignore it.
+ -- Reason: otherwise it looks as if there are two local definition sites
+ -- for the thing, and an error gets reported. Easiest thing is just to
+ -- filter them out up front. This situation only arises if a module
+ -- imports itself, or another module that imported it. (Necessarily,
+ -- this invoves a loop.)
+ --
+ -- Tiresome consequence: if you say
+ -- module A where
+ -- import B( AType )
+ -- type AType = ...
+ --
+ -- module B( AType ) where
+ -- import {-# SOURCE #-} A( AType )
+ --
+ -- then you'll get a 'B does not export AType' message. Oh well.
+
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 False{-not val-} tycon `thenRn` \ tycon_name ->
- returnRn (RnSyn tycon_name, emptyBag, emptyBag)
-
-----------------
-getConFieldNames :: Maybe ExportFlag
- -> Bag Name -> Bag Name
- -> FiniteMap RdrName ()
- -> [RdrNameConDecl]
- -> RnM_Info s ([Name], [Name])
-
-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 ->
+ filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
+
let
- all_constrs = constrs `snocBag` con_name
- all_fields = fields `unionBags` listToBag field_names
+ mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits))
+ (is_unqual name)
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 False{-notval-} cname `thenRn` \ class_name ->
- getClassOpNames (Just (nameExportFlag class_name))
- sigs `thenRn` \ op_names ->
- returnRn (RnClass class_name op_names,
- listToBag (map (\ n -> RnClassOp n class_name) op_names))
-
----------------
-getClassOpNames :: Maybe ExportFlag
- -> [RdrNameSig]
- -> RnM_Info s [Name]
-
-getClassOpNames exp [] = returnRn []
-
-getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
- getClassOpNames exp sigs `thenRn` \ op_names ->
- returnRn (op_name : op_names)
-getClassOpNames exp (_ : sigs)
- = getClassOpNames exp sigs
-\end{code}
-*********************************************************
-* *
-\subsection{Bindings}
-* *
-*********************************************************
-
-\begin{code}
-getTopBindsNames :: RdrNameHsBinds
- -> RnM_Info s (Bag RnName)
-
-getTopBindsNames binds = doBinds binds
-
-doBinds EmptyBinds = returnRn emptyBag
-doBinds (SingleBind bind) = doBind bind
-doBinds (BindWith bind sigs) = doBind bind
-doBinds (ThenBinds binds1 binds2)
- = andRn unionBags (doBinds binds1) (doBinds binds2)
-
-doBind EmptyBind = returnRn emptyBag
-doBind (NonRecBind mbind) = doMBinds mbind
-doBind (RecBind mbind) = doMBinds mbind
-
-doMBinds EmptyMonoBinds = returnRn emptyBag
-doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
-doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name
-doMBinds (AndMonoBinds mbinds1 mbinds2)
- = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
-
-doPats locn pats
- = mapRn (doPat locn) pats `thenRn` \ pats_s ->
- returnRn (unionManyBags pats_s)
-
-doPat locn WildPatIn = returnRn emptyBag
-doPat locn (LitPatIn _) = returnRn emptyBag
-doPat locn (LazyPatIn pat) = doPat locn pat
-doPat locn (VarPatIn var) = doName locn var
-doPat locn (NegPatIn pat) = doPat locn pat
-doPat locn (ParPatIn pat) = doPat locn pat
-doPat locn (ListPatIn pats) = doPats locn pats
-doPat locn (TuplePatIn pats) = doPats locn pats
-doPat locn (ConPatIn name pats) = doPats locn pats
-doPat locn (ConOpPatIn p1 op p2)
- = andRn unionBags (doPat locn p1) (doPat locn p2)
-doPat locn (AsPatIn as_name pat)
- = andRn unionBags (doName locn as_name) (doPat locn pat)
-doPat locn (RecPatIn name fields)
- = mapRn (doField locn) fields `thenRn` \ fields_s ->
- returnRn (unionManyBags fields_s)
-
-doField locn (_, pat, _) = doPat locn pat
-
-doName locn rdr
- = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
- returnRn (unitBag (RnName name))
+ qualifyImports imp_mod_name
+ (not qual_only) -- Maybe want unqualified names
+ as_mod hides
+ mk_provenance
+ filtered_avails
\end{code}
-*********************************************************
-* *
-\subsection{Creating a new global name}
-* *
-*********************************************************
\begin{code}
-newGlobalName :: SrcLoc
- -> Maybe ExportFlag
- -> Bool{-True<=>value name,False<=>tycon/class-}
- -> RdrName
- -> RnM_Info s Name
-
-newGlobalName locn maybe_exp is_val_name (Unqual name)
- = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
- getModuleRn `thenRn` \ mod ->
- rnGetUnique `thenRn` \ u ->
+importsFromLocalDecls this_mod rec_exp_fn decls
+ = mapRn (getLocalDeclBinders this_mod rec_exp_fn) decls `thenRn` \ avails_s ->
+
let
- orig = OrigName mod name
-
- (uniq, is_toplev)
- = case (lookupFM b_keys orig) of
- Just (key,_) -> (key, True)
- Nothing -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup
- case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
- Nothing -> (u, True)
- Just xx -> (uniqueOf xx, False{-builtin!-})
-
- exp = case maybe_exp of
- Just flag -> flag
- Nothing -> rec_exp_fn n
-
- n = if is_toplev
- then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
- else mkWiredInName uniq orig exp
- in
- returnRn n
+ avails = concat avails_s
-newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
- | opt_CompilingGhcInternals
- -- we are actually defining something that compiler knows about (e.g., Bool)
+ all_names :: [Name] -- All the defns; no dups eliminated
+ all_names = [name | avail <- avails, name <- availNames avail]
- = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
- let
- orig = OrigName mod name
-
- (uniq, is_toplev)
- = case (lookupFM b_keys orig) of
- Just (key,_) -> (key, True)
- Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
- Nothing -> (panic "newGlobalName:Qual:uniq", True)
- Just xx -> (uniqueOf xx, False{-builtin!-})
-
- exp = case maybe_exp of
- Just flag -> flag
- Nothing -> rec_exp_fn n
-
- n = if is_toplev
- then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
- else mkWiredInName uniq orig exp
+ dups :: [[Name]]
+ (_, dups) = removeDups compare all_names
in
- returnRn n
-
- | otherwise
- = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
- returnRn (panic "newGlobalName:Qual")
+ -- Check for duplicate definitions
+ mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
+
+ -- Record that locally-defined things are available
+ recordLocalSlurps avails `thenRn_`
+
+ -- Build the environment
+ qualifyImports (moduleName this_mod)
+ True -- Want unqualified names
+ Nothing -- no 'as M'
+ [] -- Hide nothing
+ (\n -> LocalDef) -- Provenance is local
+ avails
+
+---------------------------
+getLocalDeclBinders :: Module
+ -> (Name -> Bool) -- Whether exported
+ -> RdrNameHsDecl -> RnMG Avails
+getLocalDeclBinders mod rec_exp_fn (TyClD tycl_decl)
+ = -- For type and class decls, we generate Global names, with
+ -- no export indicator. They need to be global because they get
+ -- permanently bound into the TyCons and Classes. They don't need
+ -- an export indicator because they are all implicitly exported.
+ getTyClDeclBinders mod tycl_decl `thenRn` \ avail ->
+ returnRn [avail]
+
+getLocalDeclBinders mod rec_exp_fn (ValD binds)
+ = mapRn (newLocalBinder mod rec_exp_fn)
+ (bagToList (collectTopBinders binds))
+
+getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc))
+ | binds_haskell_name kind
+ = newLocalBinder mod rec_exp_fn (nm, loc) `thenRn` \ avail ->
+ returnRn [avail]
+
+ | otherwise -- a foreign export
+ = returnRn []
+ where
+ binds_haskell_name (FoImport _) = True
+ binds_haskell_name FoLabel = True
+ binds_haskell_name FoExport = isDynamicExtName ext_nm
+
+getLocalDeclBinders mod rec_exp_fn (FixD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (DeprecD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (DefD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (InstD _) = returnRn []
+getLocalDeclBinders mod rec_exp_fn (RuleD _) = returnRn []
+
+---------------------------
+newLocalBinder mod rec_exp_fn (rdr_name, loc)
+ = -- Generate a local name, and with a suitable export indicator
+ newTopBinder mod rdr_name loc `thenRn` \ name ->
+ returnRn (Avail (setLocalNameSort name (rec_exp_fn name)))
\end{code}
-*********************************************************
-* *
-\subsection{Imported names}
-* *
-*********************************************************
-
-\begin{code}
-type ImportNameInfo
- = (GlobalNameInfo,
- FiniteMap OrigName RnName, -- values imported so far
- FiniteMap OrigName RnName, -- tycons/classes imported so far
- Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns;
- -- NB: this last field is in a knot
- -- and mustn't be tugged on!
-
-type RnM_IInfo s r = RnMonad ImportNameInfo s r
-
-------------------------------------------------------------------
-doImportDecls ::
- IfaceCache
- -> GlobalNameInfo -- builtin and knot name info
- -> UniqSupply
- -> [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 -> (NotExported,[mkBuiltinSrcLoc])
- -- panic "RnNames:rec_imp_fn"
- -- but the panic can show up
- -- in error messages
- 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 iface_cache False SLIT("doImportDecls")) imp_mods) >>
- -- process the imports
- doImports iface_cache i_info us all_imps
+%************************************************************************
+%* *
+\subsection{Filtering imports}
+%* *
+%************************************************************************
- ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
- return (vals, tcs, imp_mods, unquals, fixes,
- imp_errs `unionBags` errs,
- imp_warns `unionBags` warns)
+\begin{code}
+filterImports :: ModuleName -- The module being imported
+ -> WhereFrom -- Tells whether it's a {-# SOURCE #-} import
+ -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
+ -> [AvailInfo] -- What's available
+ -> RnMG ([AvailInfo], -- What's actually imported
+ [AvailInfo], -- What's to be hidden
+ -- (the unqualified version, that is)
+ -- (We need to return both the above sets, because
+ -- the qualified version is never hidden; so we can't
+ -- implement hiding by reducing what's imported.)
+ NameSet) -- What was imported explicitly
+
+ -- Complains if import spec mentions things that the module doesn't export
+ -- Warns/informs if import spec contains duplicates.
+filterImports mod from Nothing imports
+ = returnRn (imports, [], emptyNameSet)
+
+filterImports mod from (Just (want_hiding, import_items)) total_avails
+ = flatMapRn get_item import_items `thenRn` \ avails_w_explicits ->
+ let
+ (item_avails, explicits_s) = unzip avails_w_explicits
+ explicits = foldl addListToNameSet emptyNameSet explicits_s
+ in
+ if want_hiding
+ then
+ -- All imported; item_avails to be hidden
+ returnRn (total_avails, item_avails, emptyNameSet)
+ else
+ -- Just item_avails imported; nothing to be hidden
+ returnRn (item_avails, [], explicits)
where
- all_imps = implicit_prel ++ src_imps
--- all_imps = implicit_qprel ++ the_imps
-
- explicit_prelude_imp
- = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
+ import_fm :: FiniteMap OccName AvailInfo
+ import_fm = listToFM [ (nameOccName name, avail)
+ | avail <- total_avails,
+ name <- availNames avail]
+ -- Even though availNames returns data constructors too,
+ -- they won't make any difference because naked entities like T
+ -- in an import list map to TcOccs, not VarOccs.
+
+ bale_out item = addErrRn (badImportItemErr mod from item) `thenRn_`
+ returnRn []
+
+ get_item item@(IEModuleContents _) = bale_out item
+
+ get_item item@(IEThingAll _)
+ = case check_item item of
+ Nothing -> bale_out item
+ Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ addWarnRn (dodgyImportWarn mod item) `thenRn_`
+ returnRn [(avail, [availName avail])]
+ Just avail -> returnRn [(avail, [availName avail])]
+
+ get_item item@(IEThingAbs n)
+ | want_hiding -- hiding( C )
+ -- Here the 'C' can be a data constructor *or* a type/class
+ = case catMaybes [check_item item, check_item (IEThingAbs data_n)] of
+ [] -> bale_out item
+ avails -> returnRn [(a, []) | a <- avails]
+ -- The 'explicits' list is irrelevant when hiding
+ where
+ data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName)
- implicit_prel | opt_NoImplicitPrelude = []
- | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
- | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
+ get_item item
+ = case check_item item of
+ Nothing -> bale_out item
+ Just avail -> returnRn [(avail, availNames avail)]
- prel_loc = mkBuiltinSrcLoc
+ check_item item
+ | not (maybeToBool maybe_in_import_avails) ||
+ not (maybeToBool maybe_filtered_avail)
+ = Nothing
- (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
- cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
+ | otherwise
+ = Just filtered_avail
+
+ where
+ wanted_occ = rdrNameOcc (ieName item)
+ maybe_in_import_avails = lookupFM import_fm wanted_occ
- qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
- mod == pRELUDE ]
+ Just avail = maybe_in_import_avails
+ maybe_filtered_avail = filterAvail item avail
+ Just filtered_avail = maybe_filtered_avail
+\end{code}
- 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 (_,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 :: IfaceCache
- -> ImportNameInfo
- -> UniqSupply
- -> [RdrNameImportDecl] -- import declarations
- -> IO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- Bag (Module, RnName), -- unqualified import from module
- Bag RenamedFixityDecl, -- fixity info for imported names
- Bag Error,
- Bag Warning,
- Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
-
-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,rec_imp_fn) us (imp:imps)
- = let
- (us1, us2) = splitUniqSupply us
- in
- doImport iface_cache i_info us1 imp
- >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
- let
- ext_vals = foldl add_new_one done_vals (bagToList vals1)
- ext_tcs = foldl add_new_one done_tcs (bagToList tcs1)
- in
- doImports iface_cache (g_info,ext_vals,ext_tcs,rec_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
- add_new_one :: FiniteMap OrigName RnName -- ones done so far
- -> (dont_care, RnName)
- -> FiniteMap OrigName RnName -- extended
+%************************************************************************
+%* *
+\subsection{Qualifiying imports}
+%* *
+%************************************************************************
- 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')
- -- = (emptyBag, emptyBag, maybe_spec)
- --in
- --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
- fold_ies = foldBag unionBags pair_occ emptyBag
+@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec
+of an import decl, and deals with producing an @RnEnv@ with the
+right qualified names. It also turns the @Names@ in the @ExportEnv@ into
+fully fledged @Names@.
- final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
- final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
- final_vals_list = bagToList final_vals
- in
- 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}
+\begin{code}
+qualifyImports :: ModuleName -- Imported module
+ -> Bool -- True <=> want unqualified import
+ -> Maybe ModuleName -- Optional "as M" part
+ -> [AvailInfo] -- What's to be hidden
+ -> (Name -> Provenance)
+ -> Avails -- Whats imported and how
+ -> RnMG (GlobalRdrEnv, ExportAvails)
+
+qualifyImports this_mod unqual_imp as_mod hides mk_provenance avails
+ =
+ -- Make the name environment. We're talking about a
+ -- single module here, so there must be no name clashes.
+ -- In practice there only ever will be if it's the module
+ -- being compiled.
+ let
+ -- Add the things that are available
+ name_env1 = foldl add_avail emptyRdrEnv avails
- mk_occ :: FAST_STRING -> RdrName
- mk_occ str = if qual then Qual as_mod str else Unqual str
+ -- Delete things that are hidden
+ name_env2 = foldl del_avail name_env1 hides
- fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
- fst_occ (str, rn) = (mk_occ str, rn)
+ -- Create the export-availability info
+ export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails
+ in
+ returnRn (name_env2, export_avails)
- pair_occ :: RnName -> Bag (RdrName, RnName)
- pair_occ rn
- = let
- str = getLocalName rn
- qual_bag = unitBag (Qual as_mod str, rn)
- in
- if qual
- then qual_bag
- else qual_bag -- the qualified name is *also* visible
- `snocBag` (Unqual str, 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
--- | 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
--}
+ qual_mod = case as_mod of
+ Nothing -> this_mod
+ Just another_name -> another_name
--------------------------
-getOrigIEs :: ParsedIface
- -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
- -> ([IE OrigName],
- [(IE OrigName, ExportFlag)],
- Bag (Module -> SrcLoc -> Error))
+ add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
+ add_avail env avail = foldl add_name env (availNames avail)
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
- = (map mkAllIE (eltsFM exps), [], emptyBag)
+ add_name env name
+ | unqual_imp = env2
+ | otherwise = env1
+ where
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) (name,prov)
+ env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov)
+ occ = nameOccName name
+ prov = mk_provenance name
-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)
+ del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
+ where
+ rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
- = (map fst found_ies, found_ies, errs)
- where
- (found_ies, errs) = lookupIEs exps ies
-
-------------------------------------------------
-mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
-
-mkAllIE (orig,ExportAbs)
- = --ASSERT(isLexCon (nameOf orig))
- -- the ASSERT is correct, but it is too easy to
- -- trigger when writing .hi files by hand (e.g.
- -- when hackily breaking a module loop)
- IEThingAbs orig
-mkAllIE (orig, ExportAll)
- | isLexCon name_orig || isLexSpecialSym name_orig
- = IEThingAll orig
- | otherwise
- = IEVar orig
- where
- name_orig = nameOf orig
-------------
-lookupIEs :: ExportsMap
- -> [RdrNameIE]
- -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
- Bag (Module -> SrcLoc -> Error))
+mkEmptyExportAvails :: ModuleName -> ExportAvails
+mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
-lookupIEs exps ies
- = foldr go ([], emptyBag) ies
+mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
+mkExportAvails mod_name unqual_imp name_env avails
+ = (mod_avail_env, entity_avail_env)
where
- go ie (already, errs)
- = let
- str = case (ie_name ie) of
- Unqual s -> s
- Qual m s -> s
- in
- case (lookupFM exps str) of
- Nothing ->
- (already, unknownImpSpecErr ie `consBag` errs)
- Just (orig, flag) ->
- ((orig_ie orig ie, flag) : already,
- adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
-
- orig_ie orig (IEVar n) = IEVar orig
- orig_ie orig (IEThingAbs n) = IEThingAbs orig
- orig_ie orig (IEThingAll n) = IEThingAll orig
- orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
- where
- (OrigName mod _) = orig
- re_orig (Unqual s) = OrigName mod s
+ mod_avail_env = unitFM mod_name unqual_avails
- seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
+ -- unqual_avails is the Avails that are visible in *unqualfied* form
+ -- (1.4 Report, Section 5.1.1)
+ -- For example, in
+ -- import T hiding( f )
+ -- we delete f from avails
---------------------------------------------
-doOrigIEs iface_cache info mod src_loc us []
- = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
+ unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
+ | otherwise = mapMaybe prune avails
-doOrigIEs iface_cache info mod src_loc us (ie:ies)
- = let
- (us1, us2) = splitUniqSupply us
- in
- 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)
-
-----------------------
-doOrigIE :: IfaceCache
- -> ImportNameInfo
- -> Module
- -> SrcLoc
- -> UniqSupply
- -> IE OrigName
- -> IO (Bag RnName, -- values
- Bag RnName, -- tycons/classes
- Bag (RnName,ExportFlag), -- import flags
- Bag Error,
- Bag Warning)
-
-doOrigIE iface_cache info mod src_loc us ie
- = with_decl iface_cache (ie_name ie)
- avoided_fn
- (\ 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))
- where
- avoided_fn Nothing -- the thing should be in the source
- = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Left rn@(WiredInId _))) -- a builtin value brought into scope
- = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Right rn@(WiredInTyCon tc)))
- -- a builtin tc brought into scope; we also must bring its
- -- data constructors into scope
- = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
- (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
-
--------------------------
-checkOrigIE :: IfaceCache
- -> (IE OrigName, ExportFlag)
- -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
-
-checkOrigIE iface_cache (IEThingAll n, ExportAbs)
- = with_decl iface_cache n
- (\ _ -> (emptyBag, emptyBag))
- (\ 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
- (\ _ -> (emptyBag, emptyBag))
- (\ 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 origs
- | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
- = emptyBag
- | otherwise
- = unitBag (withImpSpecErr str n has origs)
-
-checkOrigIE iface_cache other
- = return (emptyBag, emptyBag)
-
------------------------
-with_decl :: IfaceCache
- -> OrigName
- -> (Maybe (Either RnName RnName) -> something) -- if avoided..
- -> (Error -> something) -- if an error...
- -> (RdrIfaceDecl -> something) -- if OK...
- -> IO something
-
-with_decl iface_cache n do_avoid do_err do_decl
- = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
- case maybe_decl of
- CachingAvoided info -> return (do_avoid info)
- CachingFail err -> return (do_err err)
- CachingHit decl -> return (do_decl decl)
- where
- n_name = nameOf n
+ prune (Avail n) | unqual_in_scope n = Just (Avail n)
+ prune (Avail n) | otherwise = Nothing
+ prune (AvailTC n ns) | null uqs = Nothing
+ | otherwise = Just (AvailTC n uqs)
+ where
+ uqs = filter unqual_in_scope ns
--------------
-getFixityDecl :: IfaceCache
- -> RnName
- -> IO (Maybe RenamedFixityDecl, Bag Error)
+ unqual_in_scope n = unQualInScope name_env n
-getFixityDecl iface_cache rn
- = let
- (OrigName mod str) = origName "getFixityDecl" rn
+ entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
+ name <- availNames avail]
- succeeded infx i = return (Just (infx rn i), emptyBag)
- in
- cachedIface iface_cache True str 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
-
-adderr_if True err errs = err `consBag` errs
-adderr_if False err errs = errs
+plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
+plusExportAvails (m1, e1) (m2, e2)
+ = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
+ -- ToDo: wasteful: we do this once for each constructor!
\end{code}
-*********************************************************
-* *
-\subsection{Actually creating the imported names}
-* *
-*********************************************************
-\begin{code}
-getIfaceDeclNames :: IE OrigName -> 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{Export list processing}
+%* *
+%************************************************************************
+
+Processing the export list.
-*********************************************************
-* *
-\subsection{Creating a new imported name}
-* *
-*********************************************************
+You might think that we should record things that appear in the export list
+as ``occurrences'' (using @addOccurrenceName@), but you'd be wrong.
+We do check (here) that they are in scope,
+but there is no need to slurp in their actual declaration
+(which is what @addOccurrenceName@ forces).
+
+Indeed, doing so would big trouble when
+compiling @PrelBase@, because it re-exports @GHC@, which includes @takeMVar#@,
+whose type includes @ConcBase.StateAndSynchVar#@, and so on...
\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
- = let
- orig = qualToOrigName rdr
+type ExportAccum -- The type of the accumulating parameter of
+ -- the main worker function in exportsFromAvail
+ = ([ModuleName], -- 'module M's seen so far
+ ExportOccMap, -- Tracks exported occurrence names
+ AvailEnv) -- The accumulated exported stuff, kept in an env
+ -- so we can common-up related AvailInfos
+
+type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
+ -- Tracks what a particular exported OccName
+ -- in an export list refers to, and which item
+ -- it came from. It's illegal to export two distinct things
+ -- that have the same occurrence name
+
+
+exportsFromAvail :: ModuleName
+ -> Maybe [RdrNameIE] -- Export spec
+ -> ExportAvails
+ -> GlobalRdrEnv
+ -> RnMG Avails
+ -- Complains if two distinct exports have same OccName
+ -- Warns about identical exports.
+ -- Complains about exports items not in scope
+exportsFromAvail this_mod Nothing export_avails global_name_env
+ = exportsFromAvail this_mod true_exports export_avails global_name_env
+ where
+ true_exports = Just $ if this_mod == mAIN_Name
+ then [IEVar main_RDR]
+ -- export Main.main *only* unless otherwise specified,
+ else [IEModuleContents this_mod]
+ -- but for all other modules export everything.
+
+exportsFromAvail this_mod (Just export_items)
+ (mod_avail_env, entity_avail_env)
+ global_name_env
+ = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports ->
+ foldlRn (exports_from_item warn_dup_exports)
+ ([], emptyFM, emptyAvailEnv) export_items
+ `thenRn` \ (_, _, export_avail_map) ->
+ let
+ export_avails :: [AvailInfo]
+ export_avails = nameEnvElts export_avail_map
in
- getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
- case ((if tycon_or_class
- then lookupFM done_tcs
- else lookupFM done_vals) orig) of
-
- Just rn -> returnRn (getName rn)
- Nothing ->
- rnGetUnique `thenRn` \ u ->
- let
- uniq = case lookupFM b_keys orig of
- Nothing -> u
- Just (key,_) -> key
-
- exp = case maybe_exp of
- Just xx -> xx
- Nothing -> rec_exp_fn n
-
- imp = case maybe_imp of
- Just xx -> xx
- Nothing -> imp_flag
-
- (imp_flag, imp_locs) = rec_imp_fn n
-
- n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
- in
- returnRn n
-\end{code}
+ returnRn export_avails
-\begin{code}
-globalDupNamesErr rdr rns sty
- = 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)
+ exports_from_item :: Bool -> ExportAccum -> RdrNameIE -> RnMG ExportAccum
+
+ exports_from_item warn_dups acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ | mod `elem` mods -- Duplicate export of M
+ = warnCheckRn warn_dups (dupModuleExport mod) `thenRn_`
+ returnRn acc
+
+ | otherwise
+ = case lookupFM mod_avail_env mod of
+ Nothing -> failWithRn acc (modExportErr mod)
+ Just mod_avails -> foldlRn (check_occs ie) occs mod_avails
+ `thenRn` \ occs' ->
+ let
+ avails' = foldl addAvail avails mod_avails
+ in
+ returnRn (mod:mods, occs', avails')
+
+ exports_from_item warn_dups acc@(mods, occs, avails) ie
+ = lookupSrcName global_name_env (ieName ie) `thenRn` \ name ->
+
+ -- See what's available in the current environment
+ case lookupUFM entity_avail_env name of {
+ Nothing -> -- I can't see why this should ever happen; if the thing
+ -- is in scope at all it ought to have some availability
+ pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
+ returnRn acc ;
+
+ Just avail ->
+
+ -- Filter out the bits we want
+ case filterAvail ie avail of {
+ Nothing -> -- Not enough availability
+ failWithRn acc (exportItemErr ie) ;
+
+ Just export_avail ->
+
+ -- Phew! It's OK! Now to check the occurrence stuff!
+ warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
+ check_occs ie occs export_avail `thenRn` \ occs' ->
+ returnRn (mods, occs', addAvail avails export_avail)
+ }}
+
+
+
+ok_item (IEThingAll _) (AvailTC _ [n]) = False
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ok_item _ _ = True
+
+check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
+check_occs ie occs avail
+ = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports ->
+ foldlRn (check warn_dup_exports) occs (availNames avail)
where
- 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
+ check warn_dup occs name
+ = case lookupFM occs name_occ of
+ Nothing -> returnRn (addToFM occs name_occ (name, ie))
+ Just (name', ie')
+ | name == name' -> -- Duplicate export
+ warnCheckRn warn_dup
+ (dupExportWarn name_occ ie ie')
+ `thenRn_` returnRn occs
+
+ | otherwise -> -- Same occ name but different names: an error
+ failWithRn occs (exportClashErr name_occ ie ie')
+ where
+ name_occ = nameOccName name
+
+mk_export_fn :: NameSet -> (Name -> Bool) -- True => exported
+mk_export_fn exported_names = \name -> name `elemNameSet` exported_names
+\end{code}
-qualPreludeImportWarn (ImportDecl m _ _ _ locn)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "qualified import of prelude module", ppPStr m])
+%************************************************************************
+%* *
+\subsection{Errors}
+%* *
+%************************************************************************
-dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
- = ppAboves (item1 : map dup_item dup_quals)
+\begin{code}
+badImportItemErr mod from ie
+ = sep [ptext SLIT("Module"), quotes (ppr mod), source_import,
+ ptext SLIT("does not export"), quotes (ppr ie)]
+ where
+ source_import = case from of
+ ImportByUserSource -> ptext SLIT("(hi-boot interface)")
+ other -> empty
+
+dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item
+dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item
+
+dodgyMsg kind item@(IEThingAll tc)
+ = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item),
+ ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"),
+ ptext SLIT("but it has none; it is a type synonym or abstract type or class") ]
+
+modExportErr mod
+ = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (ppr mod)]
+
+exportItemErr export_item
+ = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
+ ptext SLIT("attempts to export constructors or class methods that are not visible here") ]
+
+exportClashErr occ_name ie1 ie2
+ = hsep [ptext SLIT("The export items"), quotes (ppr ie1)
+ ,ptext SLIT("and"), quotes (ppr ie2)
+ ,ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)]
+
+dupDeclErr (n:ns)
+ = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n),
+ nest 4 (vcat (map ppr sorted_locs))]
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 "'"])
+ sorted_locs = sortLt occ'ed_before (map nameSrcLoc (n:ns))
+ occ'ed_before a b = LT == compare a b
+
+dupExportWarn occ_name ie1 ie2
+ = hsep [quotes (ppr occ_name),
+ ptext SLIT("is exported by"), quotes (ppr ie1),
+ ptext SLIT("and"), quotes (ppr ie2)]
+
+dupModuleExport mod
+ = hsep [ptext SLIT("Duplicate"),
+ quotes (ptext SLIT("Module") <+> ppr mod),
+ ptext SLIT("in export list")]
\end{code}