X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=b0a69968939c0234cc32a026066e84868db67df7;hb=3721dd37a707d2aacb5cac814410a78096e28a2c;hp=7777049248eafbcdc6e8ea00bb1fb71267d7c4df;hpb=e47dd5d2e5e6dadec89fd0c36d53a14e686dcbfa;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 7777049..b0a6996 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -1,628 +1,652 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -module RnEnv where -- Export everything +module RnEnv ( + newTopSrcBinder, + lookupLocatedBndrRn, lookupBndrRn, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocatedGlobalOccRn, lookupGlobalOccRn, + lookupTopFixSigNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupLocatedSigOccRn, + lookupLocatedInstDeclBndr, + lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + + newLocalsRn, newIPNameRn, + bindLocalNames, bindLocalNamesFV, + bindLocatedLocalsFV, bindLocatedLocalsRn, + bindPatSigTyVars, bindPatSigTyVarsFV, + bindTyVarsRn, extendTyVarEnvFVRn, + bindLocalFixities, + + checkDupNames, mapFvRn, + warnUnusedMatches, warnUnusedModules, warnUnusedImports, + warnUnusedTopBinds, warnUnusedLocalBinds, + dataTcOccs, unknownNameErr, + ) where #include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, - opt_WarnUnusedBinds, opt_WarnUnusedImports ) +import LoadIface ( loadSrcInterface ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn -import RdrHsSyn ( RdrName(..), RdrNameIE, - rdrNameOcc, isQual, qual, isClassDataConRdrName +import RdrHsSyn ( extractHsTyRdrTyVars ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, + mkRdrUnqual, setRdrNameSpace, rdrNameOcc, + pprGlobalRdrEnv, lookupGRE_RdrName, + isExact_maybe, isSrcRdrName, + GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, + isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, + Provenance(..), pprNameProvenance, ImportSpec(..) ) -import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) -import RnMonad -import ErrUtils ( ErrMsg ) -import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..), - occNameFlavour, getSrcLoc, occNameString, - NameSet, emptyNameSet, addListToNameSet, nameSetToList, - mkLocalName, mkGlobalName, modAndOcc, - nameOccName, setNameProvenance, isVarOcc, getNameProvenance, - pprOccName, isLocalName - ) -import TyCon ( TyCon ) -import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) -import FiniteMap -import Unique ( Unique, Uniquable(..), unboundKey ) -import UniqFM ( listToUFM, plusUFM_C ) +import HsTypes ( hsTyVarName, replaceTyVarName ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import TcRnMonad +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, + nameSrcLoc, nameOccName, nameModuleName, nameParent ) +import NameSet +import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) +import Module ( Module, ModuleName, moduleName, mkHomeModule ) +import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) import UniqSupply -import SrcLoc ( SrcLoc, noSrcLoc ) +import BasicTypes ( IPName, mapIPName ) +import SrcLoc ( srcSpanStart, Located(..), eqLocated, unLoc, + srcLocSpan ) import Outputable -import Util ( removeDups ) -import List ( nub ) -import Char ( isAlphanum ) +import ListSetOps ( removeDups ) +import List ( nubBy ) +import CmdLineOpts +import FastString ( FastString ) \end{code} - - %********************************************************* %* * -\subsection{Making new names} + Source-code binders %* * %********************************************************* \begin{code} -newImportedGlobalName :: Module -> OccName - -> IfaceFlavour - -> RnM s d Name -newImportedGlobalName mod occ hif - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - key = (mod,occ) - prov = NonLocalDef noSrcLoc hif False - in - case lookupFM cache key of - - -- A hit in the cache! - -- If it has no provenance at the moment then set its provenance - -- so that it has the right HiFlag component. - -- (This is necessary - -- for known-key things. For example, GHCmain.lhs imports as SOURCE - -- Main; but Main.main is a known-key thing.) - -- Don't fiddle with the provenance if it already has one - Just name -> case getNameProvenance name of - NoProvenance -> let - new_name = setNameProvenance name prov - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - other -> returnRn name - - Nothing -> -- Miss in the cache! - -- Build a new original name, and put it in the cache - let - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - name = mkGlobalName uniq mod occ prov - new_cache = addToFM cache key name - in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn name - -{- - let - pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->" - <+> ppr name - in - pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ, - brackets (sep (map pprC (fmToList cache))), - text "" - ]) $ --} - - -newLocallyDefinedGlobalName :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM s d Name -newLocallyDefinedGlobalName mod occ rec_exp_fn loc - = -- First check the cache - getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - key = (mod,occ) - in - case lookupFM cache key of - - -- A hit in the cache! - -- Overwrite whatever provenance is in the cache already; - -- this updates WiredIn things and known-key things, - -- which are there from the start, to LocalDef. - Just name -> let - new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name)) - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` - returnRn new_name - - -- Miss in the cache! - -- Build a new original name, and put it in the cache - Nothing -> let - provenance = LocalDef loc (rec_exp_fn new_name) - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - new_name = mkGlobalName uniq mod occ provenance - new_cache = addToFM cache key new_name - in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn new_name - - --- newDfunName is a variant, specially for dfuns. --- When renaming derived definitions we are in *interface* mode (because we can trip --- over original names), but we still want to make the Dfun locally-defined. --- So we can't use whether or not we're in source mode to decide the locally-defined question. -newDfunName :: OccName -> OccName -> Maybe RdrName -> SrcLoc -> RnMS s Name -newDfunName _ _ (Just n) src_loc -- Imported ones have "Just n" - = getModuleRn `thenRn` \ mod_name -> - newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} -newDfunName cl_nm tycon_nm Nothing src_loc -- Local instance decls have a "Nothing" - = getModuleRn `thenRn` \ mod_name -> - newInstUniq name `thenRn` \ inst_uniq -> - let - dfun_occ = VarOcc (_PK_ ("$d" ++ (_UNPK_ name) ++ show inst_uniq)) - in - newLocallyDefinedGlobalName mod_name dfun_occ - (\_ -> Exported) src_loc - where - {- - Dictionary names have the following form - - $d - - where "n" is a positive number, and "tycon" is the - name of the type constructor for which a "class" - instance is derived. - - Prefixing dictionary names with their class and instance - types improves the behaviour of the recompilation checker. - (fewer recompilations required should an instance or type - declaration be added to a module.) - -} - -- We're dropping the modids on purpose. - tycon_nm_str = occNameString tycon_nm - cl_nm_str = occNameString cl_nm - - -- give up on any type constructor that starts with a - -- non-alphanumeric char (e.g., [] (,*) - name - | (_NULL_ tycon_nm_str) || not (isAlphanum (_HEAD_ (tycon_nm_str))) = cl_nm_str - | otherwise = cl_nm_str _APPEND_ tycon_nm_str - - -newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] -newLocalNames rdr_names - = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let - n = length rdr_names - (us', us1) = splitUniqSupply us - uniqs = getUniques n us1 - locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc - | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs - ] - in - setNameSupplyRn (us', inst_ns, cache) `thenRn_` - returnRn locals - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = uniqueOf name == unboundKey -\end{code} - -\begin{code} -bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS s a) - -> RnMS s a -bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - - getLocalNameEnv `thenRn` \ name_env -> - (if opt_WarnNameShadowing - then - mapRn (check_shadow name_env) rdr_names_w_loc - else - returnRn [] - ) `thenRn_` - - newLocalNames rdr_names_w_loc `thenRn` \ names -> - let - new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names) - in - setLocalNameEnv new_name_env (enclosed_scope names) - where - check_shadow name_env (rdr_name,loc) - = case lookupFM name_env rdr_name of - Nothing -> returnRn () - Just name -> pushSrcLocRn loc $ - addWarnRn (shadowedNameWarn rdr_name) - -bindLocalsRn doc_str rdr_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn (text doc_str) - (rdr_names `zip` repeat loc) - enclosed_scope - -bindTyVarsRn doc_str tyvar_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - let - located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names] - in - bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope (zipWith replaceTyVarName tyvar_names names) - - -- Works in any variant of the renamer monad -checkDupOrQualNames, checkDupNames :: SDoc - -> [(RdrName, SrcLoc)] - -> RnM s d () +newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name +newTopSrcBinder mod mb_parent (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = returnM name + + | isOrig rdr_name + = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name ) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module + -- + -- Because of this latter case, we take the module from 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 (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent + (srcSpanStart loc) --TODO, should pass the whole span -checkDupOrQualNames doc_str rdr_names_w_loc - = -- Check for use of qualified names - mapRn (qualNameErr doc_str) quals `thenRn_` - checkDupNames doc_str rdr_names_w_loc - where - quals = filter (isQual.fst) rdr_names_w_loc - -checkDupNames doc_str rdr_names_w_loc - = -- Check for dupicated names in a binding group - mapRn (dupNamesErr doc_str) dups `thenRn_` - returnRn () + | otherwise + = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) where - (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc - - --- Yuk! -ifaceFlavour name = case getNameProvenance name of - NonLocalDef _ hif _ -> hif - other -> HiFile -- Shouldn't happen + rdr_mod = rdrNameModule rdr_name \end{code} - %********************************************************* %* * -\subsection{Looking up names} + Source code occurrences %* * %********************************************************* Looking up a name in the RnEnv. \begin{code} -lookupRn :: NameEnv -> RdrName -> RnMS s Name -lookupRn name_env rdr_name - = case lookupFM name_env rdr_name of - - -- Found it! - Just name -> returnRn name - - -- Not found - Nothing -> getModeRn `thenRn` \ mode -> - case mode of - -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - - -- Not found when processing an imported declaration, - -- so we create a new name for the purpose - InterfaceMode _ -> - case rdr_name of - - Qual mod_name occ hif -> newGlobalName mod_name occ hif - - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - Unqual occ -> getModuleRn `thenRn ` \ mod_name -> - newGlobalName mod_name occ HiFile - +lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedBndrRn = wrapLocM lookupBndrRn +lookupBndrRn :: RdrName -> RnM Name +-- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd lookupBndrRn rdr_name - = getNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name - --- Just like lookupRn except that we record the occurrence too --- Perhaps surprisingly, even wired-in names are recorded. --- Why? So that we know which wired-in names are referred to when --- deciding which instance declarations to import. -lookupOccRn :: RdrName -> RnMS s Name -lookupOccRn rdr_name - = getNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name `thenRn` \ name -> - addOccurrenceName name - --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. It's used for record field names only. -lookupGlobalOccRn :: RdrName -> RnMS s Name -lookupGlobalOccRn rdr_name - = getGlobalNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name `thenRn` \ name -> - addOccurrenceName name - - --- mungePrintUnqual is used to make *imported* *occurrences* print unqualified --- if they were mentioned unqualified in the source code. --- This improves error messages from the type checker. --- NB: the binding site is treated differently; see lookupBndrRn --- After the type checker all occurrences are replaced by the one --- at the binding site. -mungePrintUnqual (Qual _ _ _) name = name -mungePrintUnqual (Unqual _) name = case new_prov of - Nothing -> name - Just prov' -> setNameProvenance name prov' - where - new_prov = case getNameProvenance name of - NonLocalDef loc hif False -> Just (NonLocalDef loc hif True) - other -> Nothing - --- lookupImplicitOccRn takes an RdrName representing an *original* name, and --- adds it to the occurrence pool so that it'll be loaded later. This is --- used when language constructs (such as monad comprehensions, overloaded literals, --- or deriving clauses) require some stuff to be loaded that isn't explicitly --- mentioned in the code. + = getLocalRdrEnv `thenM` \ local_env -> + case lookupLocalRdrEnv local_env rdr_name of + Just name -> returnM name + Nothing -> lookupTopBndrRn rdr_name + +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + +lookupTopBndrRn :: RdrName -> RnM Name +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. -- --- This doesn't apply in interface mode, where everything is explicit, but --- we don't check for this case: it does no harm to record an "extra" occurrence --- and lookupImplicitOccRn isn't used much in interface mode (it's only the --- Nothing clause of rnDerivs that calls it at all I think). --- [Jan 98: this comment is wrong: rnHsType uses it quite a bit.] +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. -- --- For List and Tuple types it's important to get the correct --- isLocallyDefined flag, which is used in turn when deciding --- whether there are any instance decls in this module are "special". --- The name cache should have the correct provenance, though. - -lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn (Qual mod occ hif) - = newImportedGlobalName mod occ hif `thenRn` \ name -> - addOccurrenceName name +-- 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. + +lookupTopBndrRn rdr_name + | Just name <- isExact_maybe rdr_name + -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + = getModule `thenM` \ mod -> + checkErr (isInternalName name || moduleName mod == nameModuleName name) + (badOrigBinding rdr_name) `thenM_` + returnM name + + | isOrig rdr_name + -- This deals with the case of derived bindings, where + -- we don't bother to call newTopSrcBinder first + -- We assume there is no "parent" name + = do + loc <- getSrcSpanM + newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) -addImplicitOccRn :: Name -> RnMS s Name -addImplicitOccRn name = addOccurrenceName name + | otherwise + = do { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Nothing -> unboundName rdr_name + Just gre -> returnM (gre_name gre) } + +-- lookupLocatedSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- It's clear that the 'f' in the signature must refer to A.f +-- 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 +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. + +lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) +lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) + +lookupInstDeclBndr :: Name -> RdrName -> RnM Name +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) + ; 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) } } + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + -- NB: qualified names are rejected by the parser + lookupImportedName rdr_name + +newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) +newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- + +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnM Name +lookupOccRn rdr_name + = getLocalRdrEnv `thenM` \ local_env -> + case lookupLocalRdrEnv local_env rdr_name of + Just name -> returnM name + Nothing -> lookupGlobalOccRn rdr_name -addImplicitOccsRn :: [Name] -> RnMS s () -addImplicitOccsRn names = addOccurrenceNames names +lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn -listType_RDR = qual (modAndOcc listType_name) -tupleType_RDR n = qual (modAndOcc (tupleType_name n)) +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. It's used only for +-- record field names +-- class op names in class and instance decls -charType_name = getName charTyCon -listType_name = getName listTyCon -tupleType_name n = getName (tupleTyCon n) -\end{code} +lookupGlobalOccRn rdr_name + | not (isSrcRdrName rdr_name) + = lookupImportedName rdr_name -\begin{code} -lookupFixity :: RdrName -> RnMS s Fixity -lookupFixity rdr_name - = getFixityEnv `thenRn` \ fixity_env -> - returnRn (lookupFixityEnv fixity_env 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 -> + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + getModule `thenM` \ mod -> + if isQual rdr_name && mod == iNTERACTIVE then + -- This test is not expensive, + lookupQualifiedName rdr_name -- and only happens for failed lookups + else + unboundName rdr_name } + +lookupImportedName :: RdrName -> TcRnIf m n Name +-- Lookup the occurrence of an imported name +-- The RdrName is *always* qualified or Exact +-- Treat it as an original name, and conjure up the Name +-- Usually it's Exact or Orig, but it can be Qual if it +-- comes from an hi-boot file. (This minor infelicity is +-- just to reduce duplication in the parser.) +lookupImportedName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code + = returnM n + + | otherwise -- Always Orig, even when reading a .hi-boot file + = ASSERT( not (isUnqual rdr_name) ) + lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +unboundName :: RdrName -> RnM Name +unboundName rdr_name + = do { addErr (unknownNameErr rdr_name) + ; env <- getGlobalRdrEnv; + ; traceRn (vcat [unknownNameErr rdr_name, + ptext SLIT("Global envt is:"), + nest 3 (pprGlobalRdrEnv env)]) + ; returnM (mkUnboundName rdr_name) } + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +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 + ; case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) } + +------------------------- +lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn rdr_name + = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + +lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Similar, but restricted to locally-defined things +lookupGreLocalRn rdr_name + = lookupGreRn_help rdr_name lookup_fn + where + lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) + +lookupGreRn_help :: RdrName -- Only used in error message + -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function + -> RnM (Maybe GlobalRdrElt) +-- Checks for exactly one match; reports deprecations +-- Returns Nothing, without error, if too few +lookupGreRn_help rdr_name lookup + = do { env <- getGlobalRdrEnv + ; case lookup env of + [] -> returnM Nothing + [gre] -> returnM (Just gre) + gres -> do { addNameClashErrRn rdr_name gres + ; returnM (Just (head gres)) } } + +------------------------------ +-- GHCi support +------------------------------ + +-- A qualified name on the command line can refer to any module at all: we +-- try to load the interface if we don't already have it. +lookupQualifiedName :: RdrName -> RnM Name +lookupQualifiedName rdr_name + = let + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + in + loadSrcInterface doc mod False `thenM` \ iface -> + + case [ (mod,occ) | + (mod,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + name == occ ] of + ((mod,occ):ns) -> ASSERT (null ns) + lookupOrig mod occ + _ -> unboundName rdr_name + where + doc = ptext SLIT("Need to find") <+> ppr rdr_name \end{code} -mkImportFn returns a function that takes a Name and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the Name's provenance to guide whether or not to print the name qualified -in error messages. +%********************************************************* +%* * + Fixities +%* * +%********************************************************* \begin{code} -mkImportFn :: RnEnv -> Name -> Bool -mkImportFn (RnEnv env _) - = lookup +lookupTopFixSigNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +lookupTopFixSigNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too + | otherwise + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; return [gre_name gre | Just gre <- mb_gres] } + +-------------------------------- +bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a +-- Used for nested fixity decls +-- No need to worry about type constructors here, +-- Should check for duplicates but we don't +bindLocalFixities fixes thing_inside + | null fixes = thing_inside + | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> + extendFixityEnv new_bit thing_inside where - lookup name = case lookupFM env (Unqual (nameOccName name)) of - Just (name', _) -> name == name' - Nothing -> False + rn_sig (FixitySig lv@(L loc v) fix) + = addLocM lookupBndrRn lv `thenM` \ new_v -> + returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) \end{code} -%************************************************************************ -%* * -\subsection{Envt utility functions} -%* * -%************************************************************************ - -=============== RnEnv ================ -\begin{code} -plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = plusGlobalNameEnvRn n1 n2 `thenRn` \ n -> - plusFixityEnvRn f1 f2 `thenRn` \ f -> - returnRn (RnEnv n f) -\end{code} +-------------------------------- +lookupFixity is a bit strange. +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv -=============== NameEnv ================ -\begin{code} -plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv -plusGlobalNameEnvRn env1 env2 - = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_` - returnRn (env1 `plusFM` env2) - -addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv -addOneToGlobalNameEnv env rdr_name name - = case lookupFM env rdr_name of - Just name2 | conflicting_name name name2 - -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_` - returnRn env - - other -> returnRn (addToFM env rdr_name name) - -delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv -delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name - -conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool -conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True -conflicting_name (n1,h1) (n2,h2) = n1 /= n2 - -- We complain of a conflict if one RdrName maps to two different Names, - -- OR if one RdrName maps to the same *locally-defined* Name. The latter - -- case is to catch two separate, local definitions of the same thing. - -- - -- If a module imports itself then there might be a local defn and an imported - -- defn of the same name; in this case the names will compare as equal, but - -- will still have different HowInScope fields +* Imported fixities are found in the HIT or PIT -lookupNameEnv :: NameEnv -> RdrName -> Maybe Name -lookupNameEnv = lookupFM -\end{code} +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with RnNames.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment -=============== FixityEnv ================ \begin{code} -plusFixityEnvRn f1 f2 - = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_` - returnRn (f1 `plusFM` f2) - -addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name + = getModule `thenM` \ this_mod -> + if nameIsLocalOrFrom this_mod name + then -- It's defined in this module + getFixityEnv `thenM` \ local_fix_env -> + traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` + returnM (lookupFixity local_fix_env name) + + else -- It's imported + -- For imported names, we have to get their fixities by doing a + -- loadHomeInterface, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + loadSrcInterface doc name_mod False `thenM` \ iface -> + returnM (mi_fix_fn iface (nameOccName name)) + where + doc = ptext SLIT("Checking fixity for") <+> ppr name + name_mod = nameModuleName name -lookupFixityEnv env rdr_name - = case lookupFM env rdr_name of - Just (fixity,_) -> fixity - Nothing -> Fixity 9 InfixL -- Default case +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +-- +-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and we don't have a systematic way to find the TyCon's Name from +-- the DataCon's name. Sigh +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName +\end{code} -bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool -bad_fix (f1,_) (f2,_) = f1 /= f2 +%************************************************************************ +%* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_NoImplicitPrelude dynamic flag. -pprFixityProvenance :: (Fixity, HowInScope) -> SDoc -pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope -\end{code} + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally +%* * +%************************************************************************ +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional + * NegApp + * NPlusKPatIn + * HsDo +respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. + +We treat the orignal (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. -=============== ExportAvails ================ \begin{code} -mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails -mkExportAvails mod_name unqual_imp name_env avails - = (mod_avail_env, entity_avail_env) +lookupSyntaxName :: Name -- The standard name + -> RnM (Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName std_name + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case + else + -- Get the similarly named thing from the local environment + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (usr_name, unitFV usr_name) where - mod_avail_env = unitFM mod_name unqual_avails - - -- unqual_avails is the Avails that are visible in *unqualfied* form - -- (1.4 Report, Section 5.1.1) - -- For example, in - -- import T hiding( f ) - -- we delete f from avails - - unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports - | otherwise = [prune avail | avail <- avails] - - prune (Avail n) | unqual_in_scope n = Avail n - prune (Avail n) | otherwise = NotAvailable - prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns) - - unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env - - entity_avail_env = listToUFM [ (name,avail) | avail <- avails, - name <- availEntityNames avail] - -plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails -plusExportAvails (m1, e1) (m2, e2) - = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2) + normal_case = returnM (std_name, emptyFVs) + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case + else + -- Get the similarly named thing from the local environment + mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> + + returnM (std_names `zip` map nlHsVar usr_names, mkFVs usr_names) + where + normal_case = returnM (std_names `zip` map nlHsVar std_names, emptyFVs) \end{code} -=============== AvailInfo ================ +%********************************************************* +%* * +\subsection{Binding} +%* * +%********************************************************* + \begin{code} -plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) -plusAvail a NotAvailable = a -plusAvail NotAvailable a = a --- Added SOF 4/97 -#ifdef DEBUG -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) -#endif - -addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names avail = addListToNameSet names (availNames avail) - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails - -availName :: AvailInfo -> Name -availName (Avail n) = n -availName (AvailTC n _) = n - -availNames :: AvailInfo -> [Name] -availNames NotAvailable = [] -availNames (Avail n) = [n] -availNames (AvailTC n ns) = ns - --- availEntityNames is used to extract the names that can appear on their own in --- an export or import list. For class decls, class methods can appear on their --- own, thus import A( op ) --- but constructors cannot; thus --- import B( T ) --- means import type T from B, not constructor T. - -availEntityNames :: AvailInfo -> [Name] -availEntityNames NotAvailable = [] -availEntityNames (Avail n) = [n] -availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns - -filterAvail :: RdrNameIE -- Wanted - -> AvailInfo -- Available - -> AvailInfo -- Resulting available; - -- NotAvailable if wanted stuff isn't there - -filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = -#ifdef DEBUG - pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ -#endif - NotAvailable +newLocalsRn :: [Located RdrName] -> RnM [Name] +newLocalsRn rdr_names_w_loc + = newUniqueSupply `thenM` \ us -> + returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us)) where - is_wanted name = nameOccName name `elem` wanted_occs - sub_names_ok = all (`elem` avail_occs) wanted_occs - avail_occs = map nameOccName ns - wanted_occs = map rdrNameOcc (want:wants) - -filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - AvailTC n [n] - -filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms - -filterAvail (IEVar _) avail@(Avail n) = avail -filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns) - where - wanted n = nameOccName n == occ - occ = rdrNameOcc v - -- The second equation happens if we import a class op, thus - -- import A( op ) - -- where op is a class operation - -filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail - -filterAvail ie avail = NotAvailable - - --- In interfaces, pprAvail gets given the OccName of the "host" thing -pprAvail avail = getPprStyle $ \ sty -> - if ifaceStyle sty then - ppr_avail (pprOccName . nameOccName) avail - else - ppr_avail ppr avail - -ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") -ppr_avail pp_name (AvailTC n ns) = hsep [ - pp_name n, - parens $ hsep $ punctuate comma $ - map pp_name ns - ] -ppr_avail pp_name (Avail n) = pp_name n -\end{code} - + mk (L loc rdr_name) uniq + | Just name <- isExact_maybe rdr_name = name + -- This happens in code generated by Template Haskell + | 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) + +bindLocatedLocalsRn :: SDoc -- Documentation string for error message + -> [Located RdrName] + -> ([Name] -> RnM a) + -> RnM a +bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope + = -- Check for duplicate names + checkDupNames doc_str rdr_names_w_loc `thenM_` + + -- Warn about shadowing, but only in source modules + ifOptM Opt_WarnNameShadowing + (checkShadowing doc_str rdr_names_w_loc) `thenM_` + + -- Make fresh Names and extend the environment + newLocalsRn rdr_names_w_loc `thenM` \ names -> + getLocalRdrEnv `thenM` \ local_env -> + setLocalRdrEnv (extendLocalRdrEnv local_env names) + (enclosed_scope names) + + +bindLocalNames names enclosed_scope + = getLocalRdrEnv `thenM` \ name_env -> + setLocalRdrEnv (extendLocalRdrEnv name_env names) + enclosed_scope + +bindLocalNamesFV names enclosed_scope + = bindLocalNames names $ + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) + + +------------------------------------- + -- binLocalsFVRn is the same as bindLocalsRn + -- except that it deals with free vars +bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) + -> RnM (a, FreeVars) +bindLocatedLocalsFV doc rdr_names enclosed_scope + = bindLocatedLocalsRn doc rdr_names $ \ names -> + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) + +------------------------------------- +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) + -- This tiresome function is used only in rnSourceDecl on InstDecl +extendTyVarEnvFVRn tyvars enclosed_scope + = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs tyvars) + +bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM a) + -> RnM a +bindTyVarsRn doc_str tyvar_names enclosed_scope + = let + located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names] + in + bindLocatedLocalsRn doc_str located_tyvars $ \ names -> + enclosed_scope (zipWith replace tyvar_names names) + where + replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2) + +bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a + -- Find the type variables in the pattern type + -- signatures that must be brought into scope +bindPatSigTyVars tys thing_inside + = getLocalRdrEnv `thenM` \ name_env -> + let + located_tyvars = nubBy eqLocated [ tv | ty <- tys, + tv <- extractHsTyRdrTyVars ty, + not (unLoc tv `elemLocalRdrEnv` name_env) + ] + -- The 'nub' is important. For example: + -- f (x :: t) (y :: t) = .... + -- We don't want to complain about binding t twice! + + doc_sig = text "In a pattern type-signature" + in + bindLocatedLocalsRn doc_sig located_tyvars thing_inside + +bindPatSigTyVarsFV :: [LHsType RdrName] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) + +------------------------------------- +checkDupNames :: SDoc + -> [Located RdrName] + -> RnM () +checkDupNames doc_str rdr_names_w_loc + = -- Check for duplicated names in a binding group + mappM_ (dupNamesErr doc_str) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc +------------------------------------- +checkShadowing doc_str loc_rdr_names + = getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> + let + check_shadow (L loc rdr_name) + | rdr_name `elemLocalRdrEnv` local_env + || not (null (lookupGRE_RdrName rdr_name global_env )) + = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + | otherwise = returnM () + in + mappM_ check_shadow loc_rdr_names +\end{code} %************************************************************************ %* * -\subsection{Finite map utilities} +\subsection{Free variable manipulation} %* * %************************************************************************ - -Generally useful function on finite maps to check for overlap. - \begin{code} -conflictsFM :: Ord a - => (b->b->Bool) -- False <=> no conflict; you can pick either - -> FiniteMap a b -> FiniteMap a b - -> [(a,(b,b))] -conflictsFM bad fm1 fm2 - = filter (\(a,(b1,b2)) -> bad b1 b2) - (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2)) - -conflictFM :: Ord a - => (b->b->Bool) - -> FiniteMap a b -> a -> b - -> Maybe (a,(b,b)) -conflictFM bad fm key elt - = case lookupFM fm key of - Just elt' | bad elt elt' -> Just (key,(elt,elt')) - other -> Nothing +-- A useful utility +mapFvRn f xs = mappM f xs `thenM` \ stuff -> + let + (ys, fvs_s) = unzip stuff + in + returnM (ys, plusFVs fvs_s) \end{code} @@ -632,71 +656,85 @@ conflictFM bad fm key elt %* * %************************************************************************ - \begin{code} -warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d () +warnUnusedModules :: [ModuleName] -> RnM () +warnUnusedModules mods + = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) + where + unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> + text "is imported, but nothing from it is used", + parens (ptext SLIT("except perhaps instances visible in") <+> + quotes (ppr m))] -warnUnusedBinds names - | opt_WarnUnusedBinds = warnUnusedNames names - | otherwise = returnRn () +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedNames names - | otherwise = returnRn () +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) -warnUnusedImports names - | opt_WarnUnusedImports = warnUnusedNames names - | otherwise = returnRn () +------------------------- +-- Helpers +warnUnusedGREs gres + = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedNames :: NameSet -> RnM s d () -warnUnusedNames names - = mapRn warn (nameSetToList names) `thenRn_` - returnRn () - where - warn name = pushSrcLocRn (getSrcLoc name) $ - addWarnRn (unusedNameWarn name) +warnUnusedLocals names + = warnUnusedBinds [(n,Nothing) | n<-names] -unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used") +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) + where reportable (name,_) = reportIfUnused (nameOccName name) -addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - | isClassDataConRdrName rdr_name - -- Nasty hack to prevent error messages complain about conflicts for ":C", - -- where "C" is a class. There'll be a message about C, and :C isn't - -- the programmer's business. There may be a better way to filter this - -- out, but I couldn't get up the energy to find it. - = returnRn () +------------------------- - | otherwise - = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2])) +warnUnusedName :: (Name, Maybe Provenance) -> RnM () +warnUnusedName (name, prov) + = addWarnAt loc (sep [msg <> colon, nest 4 (ppr name)]) + -- TODO should be a proper span + where + (loc,msg) = case prov of + Just (Imported is _) -> + ( is_loc (head is), imp_from (is_mod 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} -fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2]) +\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)]) + where + 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 -shadowedNameWarn shadow - = hcat [ptext SLIT("This binding for"), +shadowedNameWarn doc shadow + = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] + $$ doc unknownNameErr name - = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] + = sep [ptext SLIT("Not in scope:"), text flavour <+> quotes (ppr name)] where flavour = occNameFlavour (rdrNameOcc name) -qualNameErr descriptor (name,loc) - = pushSrcLocRn loc $ - addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), - quotes (ppr name), - ptext SLIT("in"), - descriptor]) - -dupNamesErr descriptor ((name,loc) : dup_things) - = pushSrcLocRn loc $ - addErrRn (hsep [ptext SLIT("Conflicting definitions for"), - quotes (ppr name), - ptext SLIT("in"), descriptor]) -\end{code} +unknownInstBndrErr cls op + = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) + +badOrigBinding name + = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) +dupNamesErr descriptor (L loc name : dup_things) + = addSrcSpan loc $ + addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + $$ + descriptor) +\end{code}