%
-% (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,
- GlobalNameInfo(..)
+ getGlobalNames
) where
-import PreludeGlaST ( MutableVar(..) )
-
-import Ubiq
-
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
+#include "HsVersions.h"
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
+ opt_SourceUnchanged, opt_WarnUnusedBinds
+ )
+
+import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
+ IE(..), ieName,
+ ForeignDecl(..), ForKind(..), isDynamic,
+ FixitySig(..), Sig(..), ImportDecl(..),
+ collectTopBinders
+ )
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
+ RdrNameHsModule, RdrNameHsDecl
+ )
+import RnIfaces ( getInterfaceExports, getDeclBinders, getDeclSysBinders,
+ recordSlurp, checkUpToDate
+ )
+import RnEnv
import RnMonad
-import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
-import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
-
-
-import Bag ( emptyBag, unitBag, consBag, unionBags, unionManyBags,
- mapBag, listToBag, bagToList )
-import CmdLineOpts ( opt_NoImplicitPrelude )
-import ErrUtils ( Error(..), Warning(..), addShortErrLocLine )
-import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
-import Id ( GenId )
-import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
-import Name ( RdrName(..), Name, isQual, mkTopLevName,
- mkImportedName, nameExportFlag, nameImportFlag,
- getLocalName, getSrcLoc, pprNonSym, moduleNamePair,
- isLexCon, isRdrLexCon, ExportFlag(..)
- )
-import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude, pRELUDE )
-import Pretty
-import SrcLoc ( SrcLoc, mkIfaceSrcLoc )
-import TyCon ( tyConDataCons )
-import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( isIn, cmpPString, sortLt, removeDups, equivClasses, panic, assertPanic )
-\end{code}
+import FiniteMap
+import PrelMods
+import PrelInfo ( main_RDR )
+import UniqFM ( lookupUFM )
+import Bag ( bagToList )
+import Maybes ( maybeToBool )
+import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
+import NameSet
+import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
+ isLocallyDefined, setNameProvenance,
+ nameOccName, getSrcLoc, pprProvenance, getNameProvenance
+ )
+import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import SrcLoc ( SrcLoc )
+import NameSet ( elemNameSet, emptyNameSet )
+import Outputable
+import Unique ( getUnique )
+import Util ( removeDups, equivClassesByUniq, sortLt )
+import List ( partition )
+\end{code}
-\begin{code}
-type GlobalNameInfo = (BuiltinNames,
- BuiltinKeys,
- Name -> ExportFlag, -- export flag
- Name -> [RdrName]) -- occurence names
-
-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 _ _)
- = case initRn True mod emptyRnEnv us1
- (setExtraRn info $
- getSourceNames ty_decls cls_decls binds)
- of { ((src_vals, src_tcs), src_errs, src_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
- all_vals = bagToList (unqual_vals `unionBags` imp_vals)
- all_tcs = bagToList (unqual_tcs `unionBags` imp_tcs)
+%************************************************************************
+%* *
+\subsection{Get global names}
+%* *
+%************************************************************************
- (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
+\begin{code}
+getGlobalNames :: RdrNameHsModule
+ -> RnMG (Maybe (ExportEnv,
+ GlobalRdrEnv,
+ FixityEnv, -- Fixities for local decls only
+ NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+ -- Just for in-scope things only
+ ))
+ -- Nothing => no need to recompile
+
+getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
+ = -- These two fix-loops are to get the right
+ -- provenance information into a Name
+ fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
- dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
- cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
- dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
+ let
+ rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
+ rec_unqual_fn = unQualInScope rec_gbl_env
- all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
- all_warns = src_warns `unionBags` imp_warns
- in
- return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
- }
- where
- (us1, us2) = splitUniqSupply us
-\end{code}
+ rec_exp_fn :: Name -> ExportFlag
+ rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
+ in
+ setModuleRn this_mod $
-*********************************************************
-* *
-\subsection{Top-level source names}
-* *
-*********************************************************
+ -- 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) ->
-\begin{code}
-getSourceNames ::
- [RdrNameTyDecl]
- -> [RdrNameClassDecl]
- -> RdrNameHsBinds
- -> RnM_Info s (Bag RnName, -- values
- 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 ->
- returnRn (unionManyBags constrs_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
-
-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))
-
-getTyDeclNames (TySynonym tycon _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- returnRn (RnSyn tycon_name, 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
-
-
-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 ->
- 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 exp []
- = returnRn []
-getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp op `thenRn` \ op_name ->
- getClassOpNames exp sigs `thenRn` \ op_names ->
- returnRn (op_name : op_names)
-getClassOpNames exp (_ : sigs)
- = getClassOpNames exp sigs
-\end{code}
+ -- PROCESS IMPORT DECLS
+ -- Do the non {- SOURCE -} ones first, so that we get a helpful
+ -- warning for {- SOURCE -} ones that are unnecessary
+ let
+ (source, ordinary) = partition is_source_import all_imports
+ is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
+ is_source_import other = False
+ in
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary
+ `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source
+ `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
+
+ -- 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{Bindings}
-* *
-*********************************************************
+ all_avails :: ExportAvails
+ all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
+ in
+ -- TRY FOR EARLY EXIT
+ -- We can't go for an early exit before this because we have to check
+ -- for name clashes. Consider:
+ --
+ -- module A where module B where
+ -- import B h = True
+ -- f = h
+ --
+ -- Suppose I've compiled everything up, and then I add a
+ -- new definition to module B, that defines "f".
+ --
+ -- Then I must detect the name clash in A before going for an early
+ -- exit. The early-exit code checks what's actually needed from B
+ -- to compile A, and of course that doesn't include B.f. That's
+ -- why we wait till after the plusEnv stuff to do the early-exit.
+ checkEarlyExit this_mod `thenRn` \ up_to_date ->
+ if up_to_date then
+ returnRn (gbl_env, junk_exp_fn, Nothing)
+ else
+
+ -- RECORD BETTER PROVENANCES IN THE CACHE
+ -- The names in the envirnoment have better provenances (e.g. imported on line x)
+ -- than the names in the name cache. We update the latter now, so that we
+ -- we start renaming declarations we'll get the good names
+ -- The isQual is because the qualified name is always in scope
+ updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env,
+ isQual rdr_name]) `thenRn_`
+
+ -- PROCESS EXPORT LISTS
+ exportsFromAvail this_mod exports all_avails gbl_env
+ `thenRn` \ exported_avails ->
+
+ -- DONE
+ returnRn (gbl_env, exported_avails, Just all_avails)
+ ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) ->
+
+ case maybe_stuff of {
+ Nothing -> returnRn Nothing ;
+ Just all_avails ->
+
+ traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env))) `thenRn_`
+
+ -- DEAL WITH FIXITIES
+ fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
+ let
+ -- Export only those fixities that are for names that are
+ -- (a) defined in this module
+ -- (b) exported
+ exported_fixities :: [(Name,Fixity)]
+ exported_fixities = [(name,fixity)
+ | FixitySig name fixity _ <- nameEnvElts local_fixity_env,
+ isLocallyDefined name
+ ]
+ in
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_`
+
+ --- TIDY UP
+ let
+ export_env = ExportEnv exported_avails exported_fixities
+ (_, global_avail_env) = all_avails
+ in
+ returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env))
+ }
+ where
+ junk_exp_fn = error "RnNames:export_fn"
+
+ all_imports = prel_imports ++ imports
+
+ -- 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.
+ prel_imports | this_mod == pRELUDE_Name ||
+ explicit_prelude_import ||
+ opt_NoImplicitPrelude
+ = []
+
+ | 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}
-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 rdr `thenRn` \ name ->
- returnRn (unitBag (RnName name))
+checkEarlyExit mod
+ = checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ -- Found errors already, so exit now
+ returnRn True
+ else
+
+ traceRn (text "Considering whether compilation is required...") `thenRn_`
+ if not opt_SourceUnchanged then
+ -- Source code changed and no errors yet... carry on
+ traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
+ returnRn False
+ else
+
+ -- Unchanged source, and no errors yet; see if usage info
+ -- up to date, and exit if so
+ checkUpToDate mod `thenRn` \ up_to_date ->
+ putDocRn (text "Compilation" <+>
+ text (if up_to_date then "IS NOT" else "IS") <+>
+ text "required") `thenRn_`
+ returnRn up_to_date
\end{code}
-
-*********************************************************
-* *
-\subsection{Creating a new global name}
-* *
-*********************************************************
-
+
\begin{code}
-newGlobalName :: SrcLoc -> Maybe ExportFlag
- -> RdrName -> RnM_Info s Name
-
-newGlobalName locn maybe_exp rdr
- = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) ->
- getModuleRn `thenRn` \ mod ->
- rnGetUnique `thenRn` \ u ->
+importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier
+ -> RdrNameImportDecl
+ -> RnMG (GlobalRdrEnv,
+ ExportAvails)
+
+importsFromImportDecl 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) ->
+
+ if null avails 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
+
+ filterImports imp_mod_name import_spec avails
+ `thenRn` \ (filtered_avails, hides, explicits) ->
+
+ -- We 'improve' the provenance by setting
+ -- (a) the import-reason field, so that the Name says how it came into scope
+ -- including whether it's explicitly imported
+ -- (b) the print-unqualified field
+ -- But don't fiddle with wired-in things or we get in a twist
let
- (uniq, unqual)
- = case rdr of
- Qual m n -> (u, n)
- Unqual n -> case (lookupFM b_keys n) of
- Nothing -> (u, n)
- Just (key,_) -> (key, n)
-
- orig = if fromPrelude mod
- then (Unqual unqual)
- else (Qual mod unqual)
-
- exp = case maybe_exp of
- Just exp -> exp
- Nothing -> exp_fn n
-
- n = mkTopLevName uniq orig locn exp (occ_fn n)
+ improve_prov name =
+ setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
+ (is_unqual name))
+ is_explicit name = name `elemNameSet` explicits
in
- addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
- returnRn n
+ qualifyImports imp_mod_name
+ (not qual_only) -- Maybe want unqualified names
+ as_mod hides
+ filtered_avails improve_prov
+ `thenRn` \ (rdr_name_env, mod_avails) ->
+
+ returnRn (rdr_name_env, mod_avails)
\end{code}
-*********************************************************
-* *
-\subsection{Imported names}
-* *
-*********************************************************
\begin{code}
-type ImportNameInfo = (GlobalNameInfo,
- FiniteMap (Module,FAST_STRING) RnName, -- values imported so far
- FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far
- Name -> ExportFlag) -- import flag
-
-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_flags) ->
- let
- rec_imp_fm = addListToUFM_C lubExportFlag emptyUFM (bagToList rec_imp_flags)
+importsFromLocalDecls mod_name rec_exp_fn decls
+ = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s ->
- rec_imp_fn :: Name -> ExportFlag
- rec_imp_fn n = case lookupUFM rec_imp_fm n of
- Nothing -> panic "RnNames:rec_imp_fn"
- Just flag -> flag
-
- i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
- in
- doImports iface_cache i_info us (qprel_imp ++ prel_imp ++ src_imps)
- ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
- let
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- src_imps ]
- imp_warns = listToBag (map dupImportWarn imp_dups)
- prel_warns = listToBag (map qualPreludeImportWarn qual_prels)
-
- (_, imp_dups) = removeDups cmp_mod src_imps
- cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
- qual_prels = [imp | imp@(ImportDecl mod qual _ _ _) <- src_imps,
- fromPrelude mod && qual]
- in
- return (vals, tcs, imp_mods, unquals, fixes, errs,
- prel_warns `unionBags` imp_warns `unionBags` warns)
- where
- explicit_prelude_import
- = null [() | (ImportDecl mod qual _ _ _) <- src_imps,
- fromPrelude mod && not qual]
-
- qprel_imp = if opt_NoImplicitPrelude
- then [{-the flag really means it: *NO* implicit "import Prelude" -}]
- else [ImportDecl pRELUDE True Nothing Nothing mkIfaceSrcLoc]
-
- prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude
- then
- [ {-prelude imported explicitly => no import Prelude-} ]
- else
- [ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc]
-
-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)) -- import flags
-
-doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = cachedIface iface_cache mod >>= \ maybe_iface ->
- case maybe_iface of
- Failed err ->
- return (emptyBag, emptyBag, emptyBag, emptyBag,
- unitBag err, emptyBag, emptyBag)
- Succeeded iface ->
- let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
- (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec'
- in
- doOrigIEs iface_cache info mod src_loc us ies
- >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
- accumulate (map (checkOrigIE iface_cache) chk_ies)
- >>= \ chk_errs_warns ->
- accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals))
- >>= \ fix_maybes_errs ->
- let
- (chk_errs, chk_warns) = unzip chk_errs_warns
- (fix_maybes, fix_errs) = unzip fix_maybes_errs
+ avails = concat avails_s
- 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
+ all_names :: [Name] -- All the defns; no dups eliminated
+ all_names = [name | avail <- avails, name <- availNames avail]
- 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
- in
- return (final_vals, final_tcs, unquals, final_fixes,
- final_errs, final_warns, imp_flags)
- 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
+ dups :: [[Name]]
+ dups = filter non_singleton (equivClassesByUniq getUnique all_names)
+ where
+ non_singleton (x1:x2:xs) = True
+ non_singleton other = False
+ in
+ -- Check for duplicate definitions
+ mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
- fst_occ (str, rn) = (mk_occ str, rn)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
- pair_as rn = (as_mod, rn)
+ -- Record that locally-defined things are available
+ mapRn_ (recordSlurp Nothing) avails `thenRn_`
+ -- Build the environment
+ qualifyImports mod_name
+ True -- Want unqualified names
+ Nothing -- no 'as M'
+ [] -- Hide nothing
+ avails
+ (\n -> n)
-getBuiltins info mod maybe_spec
- | not (fromPrelude mod)
- = (emptyBag, emptyBag, maybe_spec)
+ where
+ newLocalName rdr_name loc = newLocalTopBinder mod (rdrNameOcc rdr_name)
+ rec_exp_fn loc
+ mod = mkThisModule mod_name
+
+getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
+ -> RdrNameHsDecl
+ -> RnMG Avails
+getLocalDeclBinders new_name (ValD binds)
+ = mapRn do_one (bagToList (collectTopBinders binds))
+ where
+ do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
+ returnRn (Avail name)
-getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
- = case maybe_spec of
- Nothing -> (all_vals, all_tcs, Nothing)
+ -- foreign declarations
+getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
+ | binds_haskell_name kind dyn
+ = new_name nm loc `thenRn` \ name ->
+ returnRn [Avail name]
- Just (True, ies) -> -- hiding does not work for builtin names
- (all_vals, all_tcs, maybe_spec)
+ | otherwise
+ = returnRn []
- Just (False, ies) -> let
- (vals,tcs,ies_left) = do_builtin ies
- in
- (vals, tcs, Just (False, ies_left))
+getLocalDeclBinders new_name decl
+ = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
+ case maybe_avail of
+ Nothing -> returnRn [] -- Instance decls and suchlike
+ Just avail -> getDeclSysBinders new_sys_name decl `thenRn_`
+ returnRn [avail]
where
- all_vals = do_all_builtin (fmToList b_val_names)
- all_tcs = do_all_builtin (fmToList b_tc_names)
+ -- The getDeclSysBinders is just to get the names of superclass selectors
+ -- etc, into the cache
+ new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc
- do_all_builtin [] = emptyBag
- do_all_builtin ((str,rn):rest)
- = (str, rn) `consBag` do_all_builtin rest
+binds_haskell_name (FoImport _) _ = True
+binds_haskell_name FoLabel _ = True
+binds_haskell_name FoExport ext_nm = isDynamic ext_nm
- 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...
- 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)
- _ -> panic "importing builtin names (1)"
-
- Nothing ->
- case (lookupFM b_val_names str) 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
+fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
+fixitiesFromLocalDecls gbl_env decls
+ = foldlRn getFixities emptyNameEnv decls
+ where
+ getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
+ getFixities acc (FixD fix)
+ = fix_decl acc fix
+
+ getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _))
+ = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
+ -- Get fixities from class decl sigs too.
+ getFixities acc other_decl
+ = returnRn acc
+
+ fix_decl acc sig@(FixitySig rdr_name fixity loc)
+ = -- Check for fixity decl for something not declared
+ case lookupRdrEnv gbl_env rdr_name of {
+ Nothing | opt_WarnUnusedBinds
+ -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
+ `thenRn_` returnRn acc
+ | otherwise -> returnRn acc ;
+
+ Just (name:_) ->
+
+ -- Check for duplicate fixity decl
+ case lookupNameEnv acc name of {
+ Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
+ `thenRn_` returnRn acc ;
+
+ Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
+ }}
+\end{code}
+%************************************************************************
+%* *
+\subsection{Filtering imports}
+%* *
+%************************************************************************
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
- = (map mkAllIE (eltsFM exps), [], emptyBag)
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
-getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
- = (map mkAllIE (eltsFM exps_left), found_ies, errs)
+\begin{code}
+filterImports :: ModuleName -- The module being imported
+ -> 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)
+ 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 Nothing imports
+ = returnRn (imports, [], emptyNameSet)
+
+filterImports mod (Just (want_hiding, import_items)) avails
+ = mapMaybeRn check_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 (avails, item_avails, emptyNameSet)
+ else
+ -- Just item_avails imported; nothing to be hidden
+ returnRn (item_avails, [], explicits)
where
- (found_ies, errs) = lookupIEs exps ies
- exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
+ import_fm :: FiniteMap OccName AvailInfo
+ import_fm = listToFM [ (nameOccName name, avail)
+ | avail <- 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.
+
+ check_item item@(IEModuleContents _)
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn Nothing
+
+ check_item item
+ | not (maybeToBool maybe_in_import_avails) ||
+ not (maybeToBool maybe_filtered_avail)
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn Nothing
+
+ | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
+ returnRn (Just (filtered_avail, explicits))
+
+ | otherwise = returnRn (Just (filtered_avail, explicits))
+
+ where
+ wanted_occ = rdrNameOcc (ieName item)
+ maybe_in_import_avails = lookupFM import_fm wanted_occ
+
+ Just avail = maybe_in_import_avails
+ maybe_filtered_avail = filterAvail item avail
+ Just filtered_avail = maybe_filtered_avail
+ explicits | dot_dot = [availName filtered_avail]
+ | otherwise = availNames filtered_avail
+
+ dot_dot = case item of
+ IEThingAll _ -> True
+ other -> False
+
+ dodgy_import = case (item, avail) of
+ (IEThingAll _, AvailTC _ [n]) -> True
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+
+ other -> False
+\end{code}
-getOrigNames (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies))
- = (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
+%************************************************************************
+%* *
+\subsection{Qualifiying imports}
+%* *
+%************************************************************************
- 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)]
+@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@.
- seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
+\begin{code}
+qualifyImports :: ModuleName -- Imported module
+ -> Bool -- True <=> want unqualified import
+ -> Maybe ModuleName -- Optional "as M" part
+ -> [AvailInfo] -- What's to be hidden
+ -> Avails -- Whats imported and how
+ -> (Name -> Name) -- Improves the provenance on imported things
+ -> RnMG (GlobalRdrEnv, ExportAvails)
+ -- NB: the Names in ExportAvails don't have the improve-provenance
+ -- function applied to them
+ -- We could fix that, but I don't think it matters
+
+qualifyImports this_mod unqual_imp as_mod hides
+ avails improve_prov
+ =
+ -- 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
+ -- Delete things that are hidden
+ name_env2 = foldl del_avail name_env1 hides
-doOrigIEs iface_cache info mod src_loc us []
- = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
+ -- Create the export-availability info
+ export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails
+ in
+ returnRn (name_env2, export_avails)
-doOrigIEs iface_cache info mod src_loc us (ie:ies)
- = doOrigIE iface_cache info mod src_loc us1 ie
- >>= \ (vals1, tcs1, errs1, warns1, imps1) ->
- doOrigIEs iface_cache info mod src_loc us2 ies
- >>= \ (vals2, tcs2, errs2, warns2, imps2) ->
- return (vals1 `unionBags` vals2,
- tcs1 `unionBags` tcs2,
- errs1 `unionBags` errs2,
- warns1 `unionBags` warns2,
- imps1 `unionBags` imps2)
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 "constructrs" [con] ns, emptyBag)
- DataSig _ cons _ _ -> (check_with "constructrs" cons 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)
+ qual_mod = case as_mod of
+ Nothing -> this_mod
+ Just another_name -> another_name
+
+ add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
+ add_avail env avail = foldl add_name env (availNames avail)
+
+ add_name env name
+ | unqual_imp = env2
+ | otherwise = env1
+ where
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name
+ env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name
+ occ = nameOccName name
+ better_name = improve_prov name
+
+ del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
+ where
+ rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
+\end{code}
-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)
+%************************************************************************
+%* *
+\subsection{Export list processing}
+%* *
+%************************************************************************
+Processing the export list.
-getFixityDecl iface_cache rn
- = let
- (mod, str) = moduleNamePair rn
- in
- cachedIface 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) -> return (Just (InfixL rn i), emptyBag)
- Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag)
- Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag)
-
-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}
+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).
-*********************************************************
-* *
-\subsection{Actually creating the imported names}
-* *
-*********************************************************
+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}
-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 ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- [con] `thenRn` \ con_names ->
- returnRn (if imp_all (imp_flag ie) then
- listToBag (map (\ n -> RnConstr n tycon_name) con_names)
- else
- emptyBag,
- unitBag (RnData tycon_name con_names),
- unitBag (RnData tycon_name con_names, imp_flag ie))
-
-getIfaceDeclNames ie (DataSig tycon cons src_loc _)
- = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- cons `thenRn` \ con_names ->
- returnRn (if imp_all (imp_flag ie) then
- listToBag (map (\ n -> RnConstr n tycon_name) con_names)
- else
- emptyBag,
- unitBag (RnData tycon_name con_names),
- unitBag (RnData tycon_name con_names, 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}
-* *
-*********************************************************
+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
+ NameEnv AvailInfo) -- 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
+ = foldlRn exports_from_item
+ ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
+ let
+ export_avails :: [AvailInfo]
+ export_avails = nameEnvElts export_avail_map
+ in
+ returnRn export_avails
-\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
- uniq = case rdr of
- Qual m n -> u
- Unqual n -> case lookupFM b_keys n 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_fn n
-
- n = mkImportedName uniq rdr imp locn exp (occ_fn n)
- in
- returnRn n
+ where
+ exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum
+
+ exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ | mod `elem` mods -- Duplicate export of M
+ = warnCheckRn opt_WarnDuplicateExports
+ (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 add_avail avails mod_avails
+ in
+ returnRn (mod:mods, occs', avails')
+
+ exports_from_item acc@(mods, occs, avails) ie
+ | not (maybeToBool maybe_in_scope)
+ = failWithRn acc (unknownNameErr (ieName ie))
+
+ | not (null dup_names)
+ = addNameClashErrRn rdr_name (name:dup_names) `thenRn_`
+ returnRn acc
+
+#ifdef DEBUG
+ -- I can't see why this should ever happen; if the thing is in scope
+ -- at all it ought to have some availability
+ | not (maybeToBool maybe_avail)
+ = pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
+ returnRn acc
+#endif
+
+ | not enough_avail
+ = failWithRn acc (exportItemErr ie)
+
+ | otherwise -- Phew! It's OK! Now to check the occurrence stuff!
+ = check_occs ie occs export_avail `thenRn` \ occs' ->
+ returnRn (mods, occs', add_avail avails export_avail)
+
+ where
+ rdr_name = ieName ie
+ maybe_in_scope = lookupFM global_name_env rdr_name
+ Just (name:dup_names) = maybe_in_scope
+ maybe_avail = lookupUFM entity_avail_env name
+ Just avail = maybe_avail
+ maybe_export_avail = filterAvail ie avail
+ enough_avail = maybeToBool maybe_export_avail
+ Just export_avail = maybe_export_avail
+
+add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+
+check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
+check_occs ie occs avail
+ = foldlRn check occs (availNames avail)
+ where
+ check occs name
+ = case lookupFM occs name_occ of
+ Nothing -> returnRn (addToFM occs name_occ (name, ie))
+ Just (name', ie')
+ | name == name' -> -- Duplicate export
+ warnCheckRn opt_WarnDuplicateExports
+ (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 -> ExportFlag)
+mk_export_fn exported_names
+ = \name -> if name `elemNameSet` exported_names
+ then Exported
+ else NotExported
\end{code}
+%************************************************************************
+%* *
+\subsection{Errors}
+%* *
+%************************************************************************
+
\begin{code}
-globalDupNamesErr rdr rns sty
- = ppHang (ppBesides [pprNonSym sty rdr, ppStr " multiply defined:"])
- 4 (ppAboves (map pp_def rns))
+badImportItemErr mod ie
+ = sep [ptext SLIT("Module"), quotes (pprModuleName mod),
+ ptext SLIT("does not export"), quotes (ppr ie)]
+
+dodgyImportWarn mod (IEThingAll tc)
+ = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod)
+ <+> ptext SLIT("exports") <+> quotes (ppr tc),
+ ptext SLIT("with no constructors/class operations;"),
+ ptext SLIT("yet it is imported with a (..)")]
+
+modExportErr mod
+ = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
+
+exportItemErr export_item
+ = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)]
+
+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 pp sorted_ns))]
where
- pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
-
-dupImportWarn dup_imps sty
- = ppStr "dupImportWarn"
+ sorted_ns = sortLt occ'ed_before (n:ns)
-qualPreludeImportWarn imp sty
- = ppStr "qualPreludeImportWarn"
+ occ'ed_before a b = LT == compare (getSrcLoc a) (getSrcLoc b)
-unknownImpSpecErr ie imp_mod locn sty
- = ppStr "unknownImpSpecErr"
+ pp n = pprProvenance (getNameProvenance n)
-duplicateImpSpecErr ie imp_mod locn sty
- = ppStr "duplicateImpSpecErr"
+dupExportWarn occ_name ie1 ie2
+ = hsep [quotes (ppr occ_name),
+ ptext SLIT("is exported by"), quotes (ppr ie1),
+ ptext SLIT("and"), quotes (ppr ie2)]
-allWhenSynImpSpecWarn n imp_mod locn sty
- = ppStr "allWhenSynImpSpecWarn"
+dupModuleExport mod
+ = hsep [ptext SLIT("Duplicate"),
+ quotes (ptext SLIT("Module") <+> pprModuleName mod),
+ ptext SLIT("in export list")]
-allWhenAbsImpSpecErr n imp_mod locn sty
- = ppStr "allWhenAbsImpSpecErr"
+unusedFixityDecl rdr_name fixity
+ = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
-withWhenAbsImpSpecErr n imp_mod locn sty
- = ppStr "withWhenAbsImpSpecErr"
+dupFixityDecl rdr_name loc1 loc2
+ = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext SLIT("at ") <+> ppr loc1,
+ ptext SLIT("and") <+> ppr loc2]
-withImpSpecErr str n has ns imp_mod locn sty
- = ppStr "withImpSpecErr"
\end{code}
projects / ghc-hetmet.git / blobdiff