X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=10fe8f61b093bbc5515fe52bfe7dcc0fa70f80b7;hb=ba58028475f0607b880ea3cad9cb646f90011092;hp=77e02b2387109567cbcadcba1bf5970340f04608;hpb=c7bd58b09eee8bb74333f3b8d2c5623dbb1f8b25;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 77e02b2..10fe8f6 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -71,7 +71,10 @@ newTopBinder mod rdr_name loc = returnM name | otherwise - = newGlobalName mod (rdrNameOcc rdr_name) loc + = ASSERT( not (isOrig rdr_name) || rdrNameModule rdr_name == moduleName mod ) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + newGlobalName mod (rdrNameOcc rdr_name) loc newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name newGlobalName mod occ loc @@ -144,14 +147,14 @@ newGlobalName2 mod_name occ Nothing -> -- No names from this module yet ioToTcRn (findModule mod_name) `thenM` \ mb_loc -> case mb_loc of - Just (mod, _) -> new_name mod - Nothing -> addErr (noModule mod_name) `thenM_` - -- Things have really gone wrong at this point, - -- so having the wrong package info in the - -- Module is the least of our worries. - new_name (mkHomeModule mod_name) - where - noModule mod_name = ptext SLIT("Can't find interface for module") <+> ppr mod_name + Right (mod, _) -> new_name mod + Left files -> + getDOpts `thenM` \ dflags -> + addErr (noIfaceErr dflags mod_name False files) `thenM_` + -- Things have really gone wrong at this point, + -- so having the wrong package info in the + -- Module is the least of our worries. + new_name (mkHomeModule mod_name) newIPName rdr_name_ip @@ -233,19 +236,12 @@ lookupTopBndrRn rdr_name -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. - -- There should never be a qualified name in a binding position - -- The parser could check this, but doesn't (yet) - | isQual rdr_name - = getSrcLocM `thenM` \ loc -> - qualNameErr (text "In its declaration") (rdr_name,loc) `thenM_` - returnM (mkUnboundName rdr_name) - - | otherwise - = ASSERT( not (isOrig rdr_name) ) - -- Original names are used only for occurrences, - -- not binding sites +-- There should never be a qualified name in a binding position in Haskell, +-- but there can be if we have read in an external-Core file. +-- The Haskell parser checks for the illegal qualified name in Haskell +-- source files, so we don't need to do so here. - getModeRn `thenM` \ mode -> + = getModeRn `thenM` \ mode -> case mode of InterfaceMode mod -> getSrcLocM `thenM` \ loc -> @@ -338,15 +334,12 @@ lookupInstDeclBndr cls_name rdr_name other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) - | isQual rdr_name -- Should never have a qualified name in a binding position - = getSrcLocM `thenM` \ loc -> - qualNameErr (text "In an instance method") (rdr_name,loc) `thenM_` - returnM (mkUnboundName rdr_name) - + | otherwise -- Occurs in derived instances, where we just -- refer directly to the right method, and avail_env -- isn't available = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + -- NB: qualified names are rejected by the parser lookupOrigName rdr_name where @@ -581,19 +574,32 @@ implicitModuleFVs source_fvs namesNeededForFlattening `plusFV` ubiquitousNames + +thProxyName :: NameSet +mkTemplateHaskellFVs :: NameSet -> NameSet -- This is a bit of a hack. When we see the Template-Haskell construct -- [| expr |] -- we are going to need lots of the ``smart constructors'' defined in -- the main Template Haskell data type module. Rather than treat them -- all as free vars at every occurrence site, we just make the Q type -- consructor a free var.... and then use that here to haul in the others -mkTemplateHaskellFVs source_fvs + #ifdef GHCI - -- Only if Template Haskell is enabled +--------------- Template Haskell enabled -------------- +thProxyName = unitFV qTyConName + +mkTemplateHaskellFVs source_fvs | qTyConName `elemNameSet` source_fvs = templateHaskellNames -#endif | otherwise = emptyFVs +#else +--------------- Template Haskell disabled -------------- + +thProxyName = emptyFVs +mkTemplateHaskellFVs source_fvs = emptyFVs +#endif +-------------------------------------------------------- + -- ubiquitous_names are loaded regardless, because -- they are needed in virtually every program ubiquitousNames @@ -819,8 +825,11 @@ checkDupOrQualNames, checkDupNames :: SDoc -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc - = -- Check for use of qualified names - mappM_ (qualNameErr doc_str) quals `thenM_` + = -- Qualified names in patterns are now rejected by the parser + -- but I'm not 100% certain that it finds all cases, so I've left + -- this check in for now. Should go eventually. + -- Hmm. Sooner rather than later.. data type decls +-- mappM_ (qualNameErr doc_str) quals `thenM_` checkDupNames doc_str rdr_names_w_loc where quals = filter (isQual . fst) rdr_names_w_loc @@ -881,7 +890,9 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs where occ = nameOccName name elt = GRE {gre_name = name, - gre_parent = parent, + gre_parent = if name == parent + then Nothing + else Just parent, gre_prov = mk_provenance name, gre_deprec = lookupDeprec deprecs name} @@ -977,44 +988,41 @@ warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () warnUnusedBinds names - = mappM_ warnUnusedGroup groups + = mappM_ warnUnusedGroup groups where -- Group by provenance - groups = equivClasses cmp names + groups = equivClasses cmp (filter reportable names) (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 + reportable (name,_) = case occNameUserString (nameOccName name) of + ('_' : _) -> False + zz_other -> True + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". + ------------------------- warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () warnUnusedGroup names - | null filtered_names = returnM () - | not is_local = returnM () - | otherwise = addSrcLoc def_loc $ - addWarn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] + addWarn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))] where - filtered_names = filter reportable names - (name1, prov1) = head filtered_names - (is_local, def_loc, msg) - = case prov1 of - LocalDef -> (True, getSrcLoc name1, text "Defined but not used") - - NonLocalDef (UserImport mod loc _) - -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") - - reportable (name,_) = case occNameUserString (nameOccName name) of - ('_' : _) -> False - zz_other -> True - -- Haskell 98 encourages compilers to suppress warnings about - -- unused names in a pattern if they start with "_". + (name1, prov1) = head names + loc1 = getSrcLoc name1 + (def_loc, msg) = case prov1 of + LocalDef -> (loc1, unused_msg) + NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod) + + unused_msg = text "Defined but not used" + imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" \end{code} \begin{code} addNameClashErrRn rdr_name (np1:nps) = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) + ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] @@ -1045,6 +1053,16 @@ dupNamesErr descriptor ((name,loc) : dup_things) $$ descriptor) +noIfaceErr dflags mod_name boot_file files + = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) + $$ extra + where + extra + | verbosity dflags < 3 = + text "(use -v to see a list of the files searched for)" + | otherwise = + hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) + warnDeprec :: GlobalRdrElt -> TcRn m () warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) = ifOptM Opt_WarnDeprecations $