X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=c2c67627a1b882287f7300a597bb53c5d27c73f1;hb=3408a36674b002bfce16750d8af782ca40b47856;hp=6b1fcb879fbd2f5f0b5888b0a20481c08a2e6163;hpb=61bfd5dd3b9d70404d6f93c030a9bb1c402b9d31;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6b1fcb8..c2c6762 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,6 +10,7 @@ module RnEnv where -- Export everything import {-# SOURCE #-} RnHiFiles +import FlattenInfo ( namesNeededForFlattening ) import HsSyn import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, @@ -21,14 +22,14 @@ 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 ) @@ -39,12 +40,12 @@ import Module ( ModuleName, moduleName, mkVanillaModule, 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, - bindIOName, returnIOName, failIOName + bindIOName, returnIOName, failIOName, thenIOName ) import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap @@ -53,12 +54,12 @@ import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) import Util ( sortLt ) +import BasicTypes ( mapIPName ) import List ( nub ) import UniqFM ( lookupWithDefaultUFM ) +import Maybe ( mapMaybe ) import CmdLineOpts import FastString ( FastString ) - -import Maybe ( isJust ) \end{code} %********************************************************* @@ -117,7 +118,7 @@ newTopBinder mod rdr_name loc 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_` @@ -160,24 +161,27 @@ newGlobalName mod_name occ (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} %********************************************************* @@ -212,7 +216,14 @@ lookupTopBndrRn rdr_name | otherwise = getModeRn `thenRn` \ mode -> if isInterfaceMode mode - then lookupIfaceName rdr_name + then lookupSysBinder rdr_name + -- lookupSysBinder uses the Module in the monad to set + -- the correct module for the binder. This is important because + -- when GHCi is reading in an old interface, it just sucks it + -- in entire (Rename.loadHomeDecls) which uses lookupTopBndrRn + -- rather than via the iface file cache which uses newTopBndrRn + -- We must get the correct Module into the thing. + else getModuleRn `thenRn` \ mod -> getGlobalNameEnv `thenRn` \ global_env -> @@ -242,6 +253,33 @@ lookupTopBndrRn rdr_name 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 @@ -316,7 +354,9 @@ lookupSrcName global_env 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 @@ -380,22 +420,22 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} getImplicitStmtFVs -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName] + = returnRn (mkFVs [printName, bindIOName, thenIOName, + returnIOName, failIOName] `plusFV` ubiquitousNames) -- 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 @@ -410,6 +450,34 @@ ubiquitousNames -- 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} %************************************************************************ @@ -470,7 +538,7 @@ newLocalsRn rdr_names_w_loc 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 @@ -526,7 +594,7 @@ bindCoreLocalRn rdr_name enclosed_scope 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 @@ -581,20 +649,12 @@ bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] -> ([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) + enclosed_scope (zipWith replaceTyVarName tyvar_names names) bindPatSigTyVars :: [RdrNameHsType] -> RnMS (a, FreeVars) @@ -654,13 +714,11 @@ mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name ch -> 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. @@ -671,12 +729,9 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails hides deprecs -- (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 @@ -688,13 +743,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails hides deprecs -- 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) @@ -703,18 +751,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails hides deprecs 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} @@ -766,8 +802,12 @@ in error messages. \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 @@ -795,7 +835,6 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) 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 @@ -893,6 +932,21 @@ sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) 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} %************************************************************************ %* * @@ -989,6 +1043,8 @@ shadowedNameWarn shadow 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