X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=933de84ff0bd90a94880de08beb081d012b5a141;hp=29a87918f81fc32247ea1c25126671f366786518;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=190f24892156953d73b55401d0467a6f1a88ce5d diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 29a8791..933de84 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,9 +1,16 @@ % -% (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} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module RnEnv ( newTopSrcBinder, lookupFamInstDeclBndr, lookupLocatedBndrRn, lookupBndrRn, @@ -12,9 +19,10 @@ module RnEnv ( lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, - lookupLocatedInstDeclBndr, + lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, - lookupGreRn, + lookupGreRn, lookupGreRn_maybe, + getLookupOccRn, newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, @@ -42,16 +50,20 @@ 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, importSpecLoc, importSpecModule ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import TcEnv ( tcLookupDataCon ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) + nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet +import NameEnv +import DataCon ( dataConFieldLabels ) import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused ) import Module ( Module, ModuleName ) @@ -62,6 +74,7 @@ import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable import Util ( sortLe ) +import Maybes import ListSetOps ( removeDups ) import List ( nubBy ) import Monad ( when ) @@ -75,8 +88,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 @@ -113,7 +126,7 @@ 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) } + ; newGlobalBinder rdr_mod rdr_occ loc } --TODO, should pass the whole span | otherwise @@ -121,7 +134,7 @@ newTopSrcBinder this_mod mb_parent (L loc 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) mb_parent (srcSpanStart loc) } + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } \end{code} %********************************************************* @@ -173,12 +186,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 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 @@ -191,28 +206,107 @@ 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 - --- lookupInstDeclBndr is used for the binders in an --- instance declaration. Here we use the class name to --- disambiguate. +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 :: Name -> Located RdrName -> RnM (Located 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. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr + where + doc = ptext SLIT("method of class") <+> quotes (ppr cls) + is_op gre@(GRE {gre_par = ParentIs n}) = n == cls + is_op other = False + +----------------------------------------------- +lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name) +-- Used for record construction and pattern matching +-- When the -fdisambiguate-record-fields flag is on, take account of the +-- constructor name to disambiguate which field to use; it's just the +-- same as for instance decls +lookupRecordBndr Nothing rdr_name + = lookupLocatedGlobalOccRn rdr_name +lookupRecordBndr (Just (L _ data_con)) rdr_name + = do { flag_on <- doptM Opt_DisambiguateRecordFields + ; if not flag_on + then lookupLocatedGlobalOccRn rdr_name + else do { + fields <- lookupConstructorFields data_con + ; let is_field gre = gre_name gre `elem` fields + ; lookup_located_sub_bndr is_field doc rdr_name + }} + where + doc = ptext SLIT("field of constructor") <+> quotes (ppr data_con) + + +lookupConstructorFields :: Name -> RnM [Name] +-- Look up the fields of a given constructor +-- * For constructors from this module, use the record field env, +-- which is itself gathered from the (as yet un-typechecked) +-- data type decls +-- +-- * For constructors from imported modules, use the *type* environment +-- since imported modles are already compiled, the info is conveniently +-- right there + +lookupConstructorFields con_name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod con_name then + do { field_env <- getRecFieldEnv + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupDataCon con_name + ; return (dataConFieldLabels con) } } -lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) +----------------------------------------------- +lookup_located_sub_bndr :: (GlobalRdrElt -> Bool) + -> SDoc -> Located RdrName + -> RnM (Located Name) +lookup_located_sub_bndr is_good doc rdr_name + = wrapLocM (lookup_sub_bndr is_good doc) rdr_name -lookupInstDeclBndr :: Name -> RdrName -> RnM Name -lookupInstDeclBndr cls_name rdr_name +lookup_sub_bndr is_good doc 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) - ; 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) - ; return (mkUnboundName rdr_name) } } + ; env <- getGlobalRdrEnv + ; case filter is_good (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) of + -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! + -- The latter does pickGREs, but we want to allow 'x' + -- even if only 'M.x' is in scope + [gre] -> return (gre_name gre) + [] -> do { addErr (unknownSubordinateErr doc rdr_name) + ; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name) + ; return (mkUnboundName rdr_name) } + gres -> do { addNameClashErrRn rdr_name gres + ; return (gre_name (head gres)) } + } | otherwise -- Occurs in derived instances, where we just -- refer directly to the right method @@ -235,20 +329,20 @@ newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) -- lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) - | not (isSrcRdrName rdr_name) - = lookupImportedName rdr_name - - | otherwise - = -- First look up the name in the normal environment. - lookupGreRn rdr_name `thenM` \ mb_gre -> - case mb_gre of { - Just gre -> returnM (gre_name gre) ; - Nothing -> newTopSrcBinder mod Nothing lrdr_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 @@ -275,7 +369,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 -> @@ -288,7 +382,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 @@ -326,17 +421,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 @@ -471,10 +578,7 @@ lookupFixityRn name --------------- lookupTyFixityRn :: Located Name -> RnM Fixity -lookupTyFixityRn (L loc n) - = do { glaExts <- doptM Opt_GlasgowExts - ; when (not glaExts) (addWarnAt loc (infixTyConWarn n)) - ; lookupFixityRn n } +lookupTyFixityRn (L loc n) = lookupFixityRn n --------------- dataTcOccs :: RdrName -> [RdrName] @@ -527,7 +631,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 @@ -584,7 +688,7 @@ newLocalsRn rdr_names_w_loc | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) -- We only bind unqualified names here -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) + mkInternalName uniq (rdrNameOcc rdr_name) loc bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [Located RdrName] @@ -756,12 +860,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 @@ -771,23 +875,25 @@ 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} @@ -811,8 +917,9 @@ unknownNameErr rdr_name nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) <+> quotes (ppr rdr_name)] -unknownInstBndrErr cls op - = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> ptext SLIT("is not a (visible)") <+> doc badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) @@ -834,8 +941,4 @@ dupNamesErr descriptor located_names 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")] \end{code}