X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=54a768af26ff9d1cbe8a4425083b73def83bc948;hp=1c5a559ee893d7c12fd64a9ce57ff28e4e913f43;hb=72e37dedee9e8a109ebda4b13e49b7133b530591;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 1c5a559..54a768a 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,11 +1,11 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 % \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} module RnEnv ( - newTopSrcBinder, + newTopSrcBinder, lookupFamInstDeclBndr, lookupLocatedBndrRn, lookupBndrRn, lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, @@ -14,6 +14,8 @@ module RnEnv ( lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupLocatedInstDeclBndr, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, + lookupGreRn, lookupGreRn_maybe, + getLookupOccRn, newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, @@ -41,6 +43,7 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, isExact_maybe, isSrcRdrName, + Parent(..), GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, Provenance(..), pprNameProvenance, @@ -49,7 +52,7 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) + nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused ) @@ -58,7 +61,7 @@ import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey import UniqSupply import BasicTypes ( IPName, mapIPName ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) + srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable import Util ( sortLe ) import ListSetOps ( removeDups ) @@ -74,8 +77,8 @@ import DynFlags %********************************************************* \begin{code} -newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name -newTopSrcBinder this_mod mb_parent (L loc rdr_name) +newTopSrcBinder :: Module -> Located RdrName -> RnM Name +newTopSrcBinder this_mod (L loc rdr_name) | Just name <- isExact_maybe rdr_name = -- This is here to catch -- (a) Exact-name binders created by Template Haskell @@ -87,14 +90,14 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- data T = (,) Int Int -- unless we are in GHC.Tup ASSERT2( isExternalName name, ppr name ) - do checkErr (this_mod == nameModule name) - (badOrigBinding rdr_name) - returnM name + do { checkM (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (badOrigBinding rdr_name) + = do { checkM (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt loc (badOrigBinding rdr_name)) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad -- @@ -112,11 +115,15 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalBinder rdr_mod rdr_occ mb_parent - (srcSpanStart loc) --TODO, should pass the whole span + ; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) } + --TODO, should pass the whole span | otherwise - = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) + = do { checkM (not (isQual rdr_name)) + (addErrAt loc (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we we get a confusing "M.T is not in scope" error later + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (srcSpanStart loc) } \end{code} %********************************************************* @@ -168,12 +175,14 @@ lookupTopBndrRn rdr_name -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder rdr_mod rdr_occ Nothing (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name ; case mb_gre of - Nothing -> unboundName rdr_name + Nothing -> do + traceRn $ text "lookupTopBndrRn" + unboundName rdr_name Just gre -> returnM (gre_name gre) } -- lookupLocatedSigOccRn is used for type signatures and pragmas @@ -186,27 +195,52 @@ lookupTopBndrRn rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn +-- +-- However, consider this case: +-- import M( f ) +-- f :: Int -> Int +-- g x = x +-- We don't want to say 'f' is out of scope; instead, we want to +-- return the imported 'f', so that later on the reanamer will +-- correctly report "misplaced type sig". lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedSigOccRn = lookupLocatedBndrRn +lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do + { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of { + Just n -> return n ; + Nothing -> do + { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Just gre -> return (gre_name gre) + Nothing -> lookupGlobalOccRn rdr_name + }}} -- lookupInstDeclBndr is used for the binders in an -- instance declaration. Here we use the class name to -- disambiguate. lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) +lookupLocatedInstDeclBndr cls rdr = wrapLocM (lookupInstDeclBndr cls) rdr lookupInstDeclBndr :: Name -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. lookupInstDeclBndr cls_name rdr_name | isUnqual rdr_name -- Find all the things the rdr-name maps to = do { -- and pick the one with the right parent name - let { is_op gre = cls_name == nameParent (gre_name gre) + let { is_op gre@(GRE {gre_par = ParentIs n}) = cls_name == n + ; is_op other = False ; occ = rdrNameOcc rdr_name ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } ; mb_gre <- lookupGreRn_help rdr_name lookup_fn ; case mb_gre of Just gre -> return (gre_name gre) Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) + ; traceRn (text "lookupInstDeclBndr" <+> ppr rdr_name) ; return (mkUnboundName rdr_name) } } | otherwise -- Occurs in derived instances, where we just @@ -218,10 +252,32 @@ lookupInstDeclBndr cls_name rdr_name newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) +-- Looking up family names in type instances is a subtle affair. The family +-- may be imported, in which case we need to lookup the occurence of a global +-- name. Alternatively, the family may be in the same binding group (and in +-- fact in a declaration processed later), and we need to create a new top +-- source binder. +-- +-- So, also this is strictly speaking an occurence, we cannot raise an error +-- message yet for instances without a family declaration. This will happen +-- during renaming the type instance declaration in RnSource.rnTyClDecl. +-- +lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name +lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of + Just gre -> returnM (gre_name gre) ; + Nothing -> newTopSrcBinder mod lrdr_name } + -------------------------------------------------- -- Occurrences -------------------------------------------------- +getLookupOccRn :: RnM (Name -> Maybe Name) +getLookupOccRn + = getLocalRdrEnv `thenM` \ local_env -> + return (lookupLocalRdrEnv local_env . mkRdrUnqual . nameOccName) + lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -248,7 +304,7 @@ lookupGlobalOccRn rdr_name | otherwise = -- First look up the name in the normal environment. - lookupGreRn rdr_name `thenM` \ mb_gre -> + lookupGreRn_maybe rdr_name `thenM` \ mb_gre -> case mb_gre of { Just gre -> returnM (gre_name gre) ; Nothing -> @@ -261,7 +317,8 @@ lookupGlobalOccRn rdr_name if isQual rdr_name && mod == iNTERACTIVE then -- This test is not expensive, lookupQualifiedName rdr_name -- and only happens for failed lookups - else + else do + traceRn $ text "lookupGlobalOccRn" unboundName rdr_name } lookupImportedName :: RdrName -> TcRnIf m n Name @@ -299,17 +356,29 @@ unboundName rdr_name lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name) -- No filter function; does not report an error on failure lookupSrcOcc_maybe rdr_name - = do { mb_gre <- lookupGreRn rdr_name + = do { mb_gre <- lookupGreRn_maybe rdr_name ; case mb_gre of Nothing -> returnM Nothing Just gre -> returnM (Just (gre_name gre)) } ------------------------- -lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) -- Just look up the RdrName in the GlobalRdrEnv -lookupGreRn rdr_name +lookupGreRn_maybe rdr_name = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) +lookupGreRn :: RdrName -> RnM GlobalRdrElt +-- If not found, add error message, and return a fake GRE +lookupGreRn rdr_name + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of { + Just gre -> return gre ; + Nothing -> do + { traceRn $ text "lookupGreRn" + ; name <- unboundName rdr_name + ; return (GRE { gre_name = name, gre_par = NoParent, + gre_prov = LocalDef }) }}} + lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) -- Similar, but restricted to locally-defined things lookupGreLocalRn rdr_name @@ -445,10 +514,9 @@ lookupFixityRn name --------------- lookupTyFixityRn :: Located Name -> RnM Fixity lookupTyFixityRn (L loc n) - = doptM Opt_GlasgowExts `thenM` \ glaExts -> - when (not glaExts) - (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` - lookupFixityRn n + = do { glaExts <- doptM Opt_GlasgowExts + ; when (not glaExts) (addWarnAt loc (infixTyConWarn n)) + ; lookupFixityRn n } --------------- dataTcOccs :: RdrName -> [RdrName] @@ -501,7 +569,7 @@ At the moment this just happens for * "do" notation We store the relevant Name in the HsSyn tree, in - * HsIntegral/HsFractional + * HsIntegral/HsFractional/HsIsString * NegApp * NPlusKPat * HsDo @@ -676,7 +744,7 @@ checkShadowing doc_str loc_rdr_names check_shadow (L loc rdr_name) | rdr_name `elemLocalRdrEnv` local_env || not (null (lookupGRE_RdrName rdr_name global_env )) - = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = addWarnAt loc (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in mappM_ check_shadow loc_rdr_names @@ -710,7 +778,7 @@ warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) + bleat (mod,loc) = addWarnAt loc (mk_warn mod) mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used,", nest 2 (ptext SLIT("except perhaps instances visible in") @@ -730,12 +798,12 @@ warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals name ------------------------- -- Helpers warnUnusedGREs gres - = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] + = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] warnUnusedLocals names - = warnUnusedBinds [(n,Nothing) | n<-names] + = warnUnusedBinds [(n,LocalDef) | n<-names] -warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds :: [(Name,Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) where reportable (name,_) | isWiredInName name = False -- Don't report unused wired-in names @@ -745,30 +813,33 @@ warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) ------------------------- -warnUnusedName :: (Name, Maybe Provenance) -> RnM () -warnUnusedName (name, prov) - = addWarnAt loc $ +warnUnusedName :: (Name, Provenance) -> RnM () +warnUnusedName (name, LocalDef) + = addUnusedWarning name (srcLocSpan (nameSrcLoc name)) + (ptext SLIT("Defined but not used")) + +warnUnusedName (name, Imported is) + = mapM_ warn is + where + warn spec = addUnusedWarning name span msg + where + span = importSpecLoc spec + pp_mod = quotes (ppr (importSpecModule spec)) + msg = ptext SLIT("Imported from") <+> pp_mod <+> ptext SLIT("but not used") + +addUnusedWarning name span msg + = addWarnAt span $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> quotes (ppr name)] - -- TODO should be a proper span - where - (loc,msg) = case prov of - Just (Imported is) - -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec)) - where - imp_spec = head is - other -> (srcLocSpan (nameSrcLoc name), unused_msg) - - 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) +addNameClashErrRn rdr_name names = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where + (np1:nps) = names msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre @@ -793,19 +864,21 @@ badOrigBinding name dupNamesErr :: SDoc -> [Located RdrName] -> RnM () dupNamesErr descriptor located_names - = setSrcSpan big_loc $ - addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), - locations, - descriptor]) + = addErrAt big_loc $ + vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + locations, descriptor] where L _ name1 = head located_names locs = map getLoc located_names big_loc = foldr1 combineSrcSpans locs - one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc + one_line = isOneLineSpan big_loc locations | one_line = empty | otherwise = ptext SLIT("Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) +badQualBndrErr rdr_name + = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name + infixTyConWarn op = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), ftext FSLIT("Use -fglasgow-exts to avoid this warning")]