import {-# SOURCE #-} RnHiFiles
+import FlattenInfo ( namesNeededForFlattening )
import HsSyn
-import RdrHsSyn ( RdrNameIE )
+import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
- mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv, rdrEnvToList,
+ mkRdrUnqual, mkRdrQual,
+ lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
unqualifyRdrName
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
- ModIface(..),
+ ModIface(..), GhciMode(..),
Deprecations(..), lookupDeprec,
extendLocalRdrEnv
)
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
- mkLocalName, mkGlobalName,
+ mkInternalName, mkExternalName,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
import PrelNames ( mkUnboundName,
derivingOccurrences,
- mAIN_Name, pREL_MAIN_Name,
- ioTyConName, intTyConName,
+ mAIN_Name, main_RDR_Unqual,
+ runMainName, intTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
+import BasicTypes ( mapIPName )
import List ( nub )
import UniqFM ( lookupWithDefaultUFM )
-import Maybes ( orElse )
+import Maybe ( mapMaybe )
import CmdLineOpts
import FastString ( FastString )
\end{code}
-- There should never be a qualified name in a binding position (except in instance decls)
-- The parser doesn't check this because the same parser parses instance decls
(if isQual rdr_name then
- qualNameErr (text "its declaration") (rdr_name,loc)
+ qualNameErr (text "In its declaration") (rdr_name,loc)
else
returnRn ()
) `thenRn_`
Nothing -> let
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
- new_name = mkGlobalName uniq mod occ loc
+ new_name = mkExternalName uniq mod occ loc
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
mod = mkVanillaModule mod_name
- name = mkGlobalName uniq mod occ noSrcLoc
+ name = mkExternalName uniq mod occ noSrcLoc
new_cache = addToFM cache key name
-newIPName rdr_name
+newIPName rdr_name_ip
= getNameSupplyRn `thenRn` \ name_supply ->
let
ipcache = nsIPs name_supply
in
case lookupFM ipcache key of
- Just name -> returnRn name
- Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
- returnRn name
+ Just name_ip -> returnRn name_ip
+ Nothing -> setNameSupplyRn new_ns `thenRn_`
+ returnRn name_ip
where
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
- name = mkIPName uniq key
- new_ipcache = addToFM ipcache key name
- where key = (rdrNameOcc rdr_name)
+ name_ip = mapIPName mk_name rdr_name_ip
+ mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name)
+ new_ipcache = addToFM ipcache key name_ip
+ new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
+ where
+ key = rdr_name_ip -- Ensures that ?x and %x get distinct Names
\end{code}
%*********************************************************
lookupSigOccRn :: RdrName -> RnMS Name
lookupSigOccRn = lookupBndrRn
+-- lookupInstDeclBndr is used for the binders in an
+-- instance declaration. Here we use the class name to
+-- disambiguate.
+
+lookupInstDeclBndr :: Name -> RdrName -> RnMS Name
+ -- We use the selector name as the binder
+lookupInstDeclBndr cls_name rdr_name
+ | isOrig rdr_name -- Occurs in derived instances, where we just
+ -- refer diectly to the right method
+ = lookupOrigName rdr_name
+
+ | otherwise
+ = getGlobalAvails `thenRn` \ avail_env ->
+ case lookupNameEnv avail_env cls_name of
+ -- The class itself isn't in scope, so cls_name is unboundName
+ -- e.g. import Prelude hiding( Ord )
+ -- instance Ord T where ...
+ -- The program is wrong, but that should not cause a crash.
+ Nothing -> returnRn (mkUnboundName rdr_name)
+ Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of
+ (n:ns)-> ASSERT( null ns ) returnRn n
+ [] -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+ other -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
+ where
+ occ = rdrNameOcc rdr_name
+
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnMS Name
lookupOccRn rdr_name
lookupOrigName :: RdrName -> RnM d Name
lookupOrigName rdr_name
- = ASSERT( isOrig rdr_name )
+ = -- NO: ASSERT( isOrig rdr_name )
+ -- Now that .hi-boot files are read by the main parser, they contain
+ -- ordinary qualified names (which we treat as Orig names here).
newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
lookupIfaceUnqual :: RdrName -> RnM d Name
-- These are all needed implicitly when compiling a statement
-- See TcModule.tc_stmts
-getImplicitModuleFVs mod_name decls -- Compiling a module
+getImplicitModuleFVs decls -- Compiling a module
= lookupOrigNames deriv_occs `thenRn` \ deriving_names ->
- returnRn (deriving_names `plusFV` implicit_main `plusFV` ubiquitousNames)
+ returnRn (deriving_names `plusFV` ubiquitousNames)
where
- -- Add occurrences for IO or PrimIO
- implicit_main | mod_name == mAIN_Name
- || mod_name == pREL_MAIN_Name = unitFV ioTyConName
- | otherwise = emptyFVs
-
+ -- deriv_classes is now a list of HsTypes, so a "normal" one
+ -- appears as a (HsClassP c []). The non-normal ones for the new
+ -- newtype-deriving extension, and they don't require any
+ -- implicit names, so we can silently filter them out.
deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
- cls <- deriv_classes,
+ HsClassP cls [] <- deriv_classes,
occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
-- ubiquitous_names are loaded regardless, because
-- Add occurrences for very frequently used types.
-- (e.g. we don't want to be bothered with making funTyCon a
-- free var at every function application!)
+ `plusFV`
+ namesNeededForFlattening
+ -- this will be empty unless flattening is activated
+
+checkMain ghci_mode mod_name gbl_env
+ -- LOOKUP main IF WE'RE IN MODULE Main
+ -- The main point of this is to drag in the declaration for 'main',
+ -- its in another module, and for the Prelude function 'runMain',
+ -- so that the type checker will find them
+ --
+ -- We have to return the main_name separately, because it's a
+ -- bona fide 'use', and should be recorded as such, but the others
+ -- aren't
+ | mod_name /= mAIN_Name
+ = returnRn (Nothing, emptyFVs, emptyFVs)
+
+ | not (main_RDR_Unqual `elemRdrEnv` gbl_env)
+ = complain_no_main `thenRn_`
+ returnRn (Nothing, emptyFVs, emptyFVs)
+
+ | otherwise
+ = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name ->
+ returnRn (Just main_name, unitFV main_name, unitFV runMainName)
+
+ where
+ complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg
+ | otherwise = addErrRn noMainMsg
+ -- In interactive mode, only warn about the absence of main
\end{code}
%************************************************************************
let
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniqs = uniqsFromSupply us1
- names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
+ names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
-> RnMS a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
= getModeRn `thenRn` \ mode ->
- getLocalNameEnv `thenRn` \ name_env ->
+ getLocalNameEnv `thenRn` \ local_env ->
+ getGlobalNameEnv `thenRn` \ global_env ->
-- Check for duplicate names
checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
-- Warn about shadowing, but only in source modules
+ let
+ check_shadow (rdr_name,loc)
+ | rdr_name `elemRdrEnv` local_env
+ || rdr_name `elemRdrEnv` global_env
+ = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name)
+ | otherwise
+ = returnRn ()
+ in
+
(case mode of
SourceMode -> ifOptRn Opt_WarnNameShadowing $
- mapRn_ (check_shadow name_env) rdr_names_w_loc
+ mapRn_ check_shadow rdr_names_w_loc
other -> returnRn ()
) `thenRn_`
-
+
newLocalsRn rdr_names_w_loc `thenRn` \ names ->
let
- new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
+ new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names)
in
setLocalNameEnv new_local_env (enclosed_scope names)
- where
- check_shadow name_env (rdr_name,loc)
- = case lookupRdrEnv name_env rdr_name of
- Nothing -> returnRn ()
- Just name -> pushSrcLocRn loc $
- addWarnRn (shadowedNameWarn rdr_name)
-
bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
-- A specialised variant when renaming stuff from interface
-- files (of which there is a lot)
let
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
- name = mkLocalName uniq (rdrNameOcc rdr_name) loc
+ name = mkInternalName uniq (rdrNameOcc rdr_name) loc
in
setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
let
-> ([HsTyVarBndr Name] -> RnMS a)
-> RnMS a
bindTyVarsRn doc_str tyvar_names enclosed_scope
- = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars ->
- enclosed_scope tyvars
-
--- Gruesome name: return Names as well as HsTyVars
-bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
- -> RnMS a
-bindTyVars2Rn doc_str tyvar_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
let
located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
- enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
-
-bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
-bindTyVarsFVRn doc_str rdr_names enclosed_scope
- = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
- enclosed_scope tyvars `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
+ enclosed_scope (zipWith replaceTyVarName tyvar_names names)
-bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
-bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
- = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
- enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
+bindPatSigTyVars :: [RdrNameHsType]
+ -> RnMS (a, FreeVars)
+ -> RnMS (a, FreeVars)
+ -- Find the type variables in the pattern type
+ -- signatures that must be brought into scope
-bindNakedTyVarsFVRn :: SDoc -> [RdrName]
- -> ([Name] -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
-bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
- = getSrcLocRn `thenRn` \ loc ->
+bindPatSigTyVars tys enclosed_scope
+ = getLocalNameEnv `thenRn` \ name_env ->
+ getSrcLocRn `thenRn` \ loc ->
let
- located_tyvars = [(tv, loc) | tv <- tyvar_names]
+ forall_tyvars = nub [ tv | ty <- tys,
+ tv <- extractHsTyRdrTyVars ty,
+ not (tv `elemFM` name_env)
+ ]
+ -- The 'nub' is important. For example:
+ -- f (x :: t) (y :: t) = ....
+ -- We don't want to complain about binding t twice!
+
+ located_tyvars = [(tv, loc) | tv <- forall_tyvars]
+ doc_sig = text "In a pattern type-signature"
in
- bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
- enclosed_scope names `thenRn` \ (thing, fvs) ->
+ bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
+ enclosed_scope `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
-> Bool -- True <=> want unqualified import
-> (Name -> Provenance)
-> Avails -- Whats imported
- -> Avails -- What's to be hidden
- -- I.e. import (imports - hides)
-> Deprecations
-> GlobalRdrEnv
-mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails hides deprecs
- = gbl_env3
+mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs
+ = gbl_env2
where
-- Make the name environment. We're talking about a
-- single module here, so there must be no name clashes.
-- (Qualified names are always imported)
gbl_env1 = foldl add_avail emptyRdrEnv avails
- -- Delete (qualified names of) things that are hidden
- gbl_env2 = foldl del_avail gbl_env1 hides
-
-- Add unqualified names
- gbl_env3 | unqual_imp = foldl add_unqual gbl_env2 (rdrEnvToList gbl_env2)
- | otherwise = gbl_env2
+ gbl_env2 | unqual_imp = foldl add_unqual gbl_env1 (rdrEnvToList gbl_env1)
+ | otherwise = gbl_env1
add_unqual env (qual_name, elts)
= foldl add_one env elts
-- the module (multiple bindings for the same name) we may get
-- duplicates. So the simple thing is to do the fold.
- del_avail env avail
- = foldl delOneFromGlobalRdrEnv env rdr_names
- where
- rdr_names = map (mkRdrQual this_mod . nameOccName)
- (availNames avail)
-
-
add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
add_avail env avail = foldl add_name env (availNames avail)
where
occ = nameOccName name
elt = GRE name (mk_provenance name) (lookupDeprec deprecs name)
-
-mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv
--- Used to construct a GlobalRdrEnv for an interface that we've
--- read from a .hi file. We can't construct the original top-level
--- environment because we don't have enough info, but we compromise
--- by making an environment from its exports
-mkIfaceGlobalRdrEnv m_avails
- = foldl add emptyRdrEnv m_avails
- where
- add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True
- (\n -> LocalDef) avails [] NoDeprecs)
- -- The NoDeprecs is a bit of a hack I suppose
\end{code}
\begin{code}
\begin{code}
unQualInScope :: GlobalRdrEnv -> Name -> Bool
--- True if 'f' is in scope, and has only one binding
+-- True if 'f' is in scope, and has only one binding,
+-- and the thing it is bound to is the name we are looking for
-- (i.e. false if A.f and B.f are both in scope as unqualified 'f')
+--
+-- This fn is only efficient if the shared
+-- partial application is used a lot.
unQualInScope env
= (`elemNameSet` unqual_names)
where
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
-emptyAvailEnv = emptyNameEnv
unitAvailEnv :: AvailInfo -> AvailEnv
unitAvailEnv a = unitNameEnv (availName a) a
n1 `lt` n2 = nameOccName n1 < nameOccName n2
\end{code}
+\begin{code}
+pruneAvails :: (Name -> Bool) -- Keep if this is True
+ -> [AvailInfo]
+ -> [AvailInfo]
+pruneAvails keep avails
+ = mapMaybe del avails
+ where
+ del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left!
+ del (Avail n) | keep n = Just (Avail n)
+ | otherwise = Nothing
+ del (AvailTC n ns) | null ns' = Nothing
+ | otherwise = Just (AvailTC n ns')
+ where
+ ns' = filter keep ns
+\end{code}
%************************************************************************
%* *
quotes (ppr shadow),
ptext SLIT("shadows an existing binding")]
+noMainMsg = ptext SLIT("No 'main' defined in module Main")
+
unknownNameErr name
= sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
where