X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=2ecaf612954c63302e2c74cf2c979ab4a69ce752;hp=1c5a559ee893d7c12fd64a9ce57ff28e4e913f43;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 1c5a559..2ecaf61 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,70 +1,95 @@ % -% (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, - lookupLocatedBndrRn, lookupBndrRn, + newTopSrcBinder, lookupFamInstDeclBndr, lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, - lookupLocatedGlobalOccRn, lookupGlobalOccRn, - lookupLocalDataTcNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, - lookupLocatedInstDeclBndr, - lookupSyntaxName, lookupSyntaxTable, lookupImportedName, + lookupLocatedGlobalOccRn, + lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupLocalDataTcNames, lookupSigOccRn, + lookupFixityRn, lookupTyFixityRn, + lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, + lookupSyntaxName, lookupSyntaxTable, + lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, + getLookupOccRn, addUsedRdrNames, newLocalsRn, newIPNameRn, - bindLocalNames, bindLocalNamesFV, + bindLocalNames, bindLocalNamesFV, + MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, + bindLocalNamesFV_WithFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalFixities, - checkDupNames, mapFvRn, + checkDupRdrNames, checkDupNames, checkShadowedNames, + checkDupAndShadowedRdrNames, + mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, + dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg, + + checkM ) where #include "HsVersions.h" import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) -import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, - LHsTyVarBndr, LHsType, - Fixity, hsLTyVarLocNames, replaceTyVarName ) +import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, - isQual_maybe, - mkRdrUnqual, setRdrNameSpace, rdrNameOcc, - pprGlobalRdrEnv, lookupGRE_RdrName, - isExact_maybe, isSrcRdrName, - GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, - isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, - Provenance(..), pprNameProvenance, - importSpecLoc, importSpecModule - ) -import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import RdrName +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) +import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) import TcRnMonad +import Id ( isRecordSelector ) import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) + nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName ) import NameSet -import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, - reportIfUnused ) +import NameEnv +import LazyUniqFM +import DataCon ( dataConFieldLabels ) +import OccName import Module ( Module, ModuleName ) -import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) +import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, + consDataConKey, hasKey, forall_tv_RDR ) import UniqSupply -import BasicTypes ( IPName, mapIPName ) -import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) +import BasicTypes ( IPName, mapIPName, Fixity ) +import ErrUtils ( Message ) +import SrcLoc import Outputable -import Util ( sortLe ) +import Util +import Maybes import ListSetOps ( removeDups ) import List ( nubBy ) -import Monad ( when ) import DynFlags +import FastString +import Control.Monad +import qualified Data.Set as Set +\end{code} + +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM + +mappM_ :: (Monad m) => (a -> m b) -> [a] -> m () +mappM_ = mapM_ + +checkM :: Monad m => Bool -> m () -> m () +checkM = unless \end{code} %********************************************************* @@ -74,8 +99,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 +112,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 +137,24 @@ 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 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 + + ; stage <- getStage + ; if isBrackStage stage then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + else + -- Normal case + newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } \end{code} %********************************************************* @@ -127,22 +165,30 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) Looking up a name in the RnEnv. +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (Trac #3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. + \begin{code} -lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) -lookupLocatedBndrRn = wrapLocM lookupBndrRn - -lookupBndrRn :: RdrName -> RnM Name --- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd -lookupBndrRn rdr_name - = getLocalRdrEnv `thenM` \ local_env -> - case lookupLocalRdrEnv local_env rdr_name of - Just name -> returnM name - Nothing -> lookupTopBndrRn rdr_name +lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ text "lookupTopBndrRn" + unboundName n lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn -lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe 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: @@ -159,69 +205,153 @@ lookupTopBndrRn :: RdrName -> RnM Name -- 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 +lookupTopBndrRn_maybe rdr_name | Just name <- isExact_maybe rdr_name - = returnM name + = returnM (Just name) | Just (rdr_mod, rdr_occ) <- isOrig_maybe 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 rdr_mod rdr_occ Nothing (srcSpanStart loc) } + ; n <- newGlobalBinder rdr_mod rdr_occ loc + ; return (Just n)} | otherwise - = do { mb_gre <- lookupGreLocalRn rdr_name + = do { -- Check for operators in type or class declarations + -- See Note [Type and class operator definitions] + let occ = rdrNameOcc rdr_name + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- doptM Opt_TypeOperators + ; checkM op_ok (addErr (opDeclErr rdr_name)) }) + + ; mb_gre <- lookupGreLocalRn rdr_name ; case mb_gre of - Nothing -> unboundName rdr_name - Just gre -> returnM (gre_name gre) } + Nothing -> returnM Nothing + Just gre -> returnM (Just $ 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 + +----------------------------------------------- +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_par = ParentIs n}) = n == cls + is_op _ = False + +----------------------------------------------- +lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name) +-- Used for record construction and pattern matching +-- When the -XDisambiguateRecordFields flag is on, take account of the +-- constructor name to disambiguate which field to use; it's just the +-- same as for instance decls +-- +-- NB: Consider this: +-- module Foo where { data R = R { fld :: Int } } +-- module Odd where { import Foo; fld x = x { fld = 3 } } +-- Arguably this should work, because the reference to 'fld' is +-- unambiguous because there is only one field id 'fld' in scope. +-- But currently it's rejected. +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 { RecFields field_env _ <- getRecFieldEnv + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupDataCon con_name + ; return (dataConFieldLabels con) } } + +----------------------------------------------- +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 + +lookup_sub_bndr :: (GlobalRdrElt -> Bool) -> SDoc -> RdrName -> RnM 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) } } + ; addUsedRdrName 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 - = ASSERT2( not (isQual rdr_name), ppr rdr_name ) - -- NB: qualified names are rejected by the parser - lookupImportedName rdr_name + -- refer directly to the right method with an Orig + -- And record fields can be Quals: C { F.f = x } + = lookupGlobalOccRn rdr_name newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) +-- If the family is declared locally, it will not yet be in the main +-- environment; hence, we pass in an extra one here, which we check first. +-- See "Note [Looking up family names in family instances]" in 'RnNames'. +-- +lookupFamInstDeclBndr :: GlobalRdrEnv -> Located RdrName -> RnM Name +lookupFamInstDeclBndr tyclGroupEnv (L loc rdr_name) + = setSrcSpan loc $ + case lookupGRE_RdrName rdr_name tyclGroupEnv of + (gre:_) -> return $ gre_name gre + -- if there is more than one, an error will be raised elsewhere + [] -> lookupOccRn rdr_name + + -------------------------------------------------- -- Occurrences -------------------------------------------------- +getLookupOccRn :: RnM (Name -> Maybe Name) +getLookupOccRn + = getLocalRdrEnv `thenM` \ local_env -> + return (lookupLocalRdrOcc local_env . nameOccName) + lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -238,57 +368,50 @@ lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn 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 +-- environment. Adds an error message if the RdrName is not in scope. +-- Also has a special case for GHCi. lookupGlobalOccRn rdr_name - | not (isSrcRdrName rdr_name) - = lookupImportedName rdr_name + = do { -- First look up the name in the normal environment. + mb_name <- lookupGlobalOccRn_maybe rdr_name + ; case mb_name of { + Just n -> return n ; + Nothing -> do + + { -- 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. + allow_qual <- doptM Opt_ImplicitImportQualified + ; mod <- getModule + -- This test is not expensive, + -- and only happens for failed lookups + ; if isQual rdr_name && allow_qual && mod == iNTERACTIVE + then lookupQualifiedName rdr_name + else unboundName rdr_name } } } + +lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- No filter function; does not report an error on failure + +lookupGlobalOccRn_maybe rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = return (Just n) - | 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 - - -- Always Orig, even when reading a .hi-boot file | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = lookupOrig rdr_mod rdr_occ + = do { n <- lookupOrig rdr_mod rdr_occ; return (Just n) } | otherwise - = pprPanic "RnEnv.lookupImportedName" (ppr rdr_name) + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of + Nothing -> return Nothing + Just gre -> return (Just (gre_name gre)) } + unboundName :: RdrName -> RnM Name unboundName rdr_name = do { addErr (unknownNameErr rdr_name) ; env <- getGlobalRdrEnv; ; traceRn (vcat [unknownNameErr rdr_name, - ptext SLIT("Global envt is:"), + ptext (sLit "Global envt is:"), nest 3 (pprGlobalRdrEnv env)]) ; returnM (mkUnboundName rdr_name) } @@ -296,19 +419,42 @@ unboundName 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) +lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) -- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn_maybe rdr_name + = do { mGre <- lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + ; case mGre of + Just gre -> + case gre_prov gre of + LocalDef -> return () + Imported _ -> addUsedRdrName rdr_name + Nothing -> + return () + ; return mGre } + +addUsedRdrName :: RdrName -> RnM () +addUsedRdrName rdr + = do { env <- getGblEnv + ; updMutVar (tcg_used_rdrnames env) + (\s -> Set.insert rdr s) } + +addUsedRdrNames :: [RdrName] -> RnM () +addUsedRdrNames rdrs + = do { env <- getGblEnv + ; updMutVar (tcg_used_rdrnames env) + (\s -> foldr Set.insert s rdrs) } + +lookupGreRn :: RdrName -> RnM GlobalRdrElt +-- If not found, add error message, and return a fake GRE lookupGreRn rdr_name - = lookupGreRn_help rdr_name (lookupGRE_RdrName 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 @@ -341,7 +487,7 @@ lookupQualifiedName rdr_name | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. - = loadSrcInterface doc mod False `thenM` \ iface -> + = loadSrcInterface doc mod False Nothing `thenM` \ iface -> case [ (mod,occ) | (mod,avails) <- mi_exports iface, @@ -355,45 +501,174 @@ lookupQualifiedName rdr_name | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) where - doc = ptext SLIT("Need to find") <+> ppr rdr_name + doc = ptext (sLit "Need to find") <+> ppr rdr_name \end{code} -%********************************************************* -%* * - Fixities -%* * -%********************************************************* +lookupSigOccRn 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 + +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". \begin{code} -lookupLocalDataTcNames :: RdrName -> RnM [Name] +lookupSigOccRn :: Maybe NameSet -- Just ns => source file; these are the binders + -- in the same group + -- Nothing => hs-boot file; signatures without + -- binders are expected + -> Sig RdrName + -> Located RdrName -> RnM (Located Name) +lookupSigOccRn mb_bound_names sig + = wrapLocM $ \ rdr_name -> + do { mb_name <- lookupBindGroupOcc mb_bound_names (hsSigDoc sig) rdr_name + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundName rdr_name) } + Right name -> return name } + +lookupBindGroupOcc :: Maybe NameSet -- Just ns => source file; these are the binders + -- in the same group + -- Nothing => hs-boot file; signatures without + -- binders are expected + -> SDoc + -> RdrName -> RnM (Either Message Name) +-- Looks up the RdrName, expecting it to resolve to one of the +-- bound names passed in. If not, return an appropriate error message +lookupBindGroupOcc mb_bound_names what rdr_name + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of + Just n -> check_local_name n + Nothing -> do -- Not defined in a nested scope + + { env <- getGlobalRdrEnv + ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; case (filter isLocalGRE gres) of + (gre:_) -> check_local_name (gre_name gre) + -- If there is more than one local GRE for the + -- same OccName, that will be reported separately + [] | null gres -> bale_out_with empty + | otherwise -> bale_out_with import_msg + }} + where + check_local_name name -- The name is in scope, and not imported + = case mb_bound_names of + Just bound_names | not (name `elemNameSet` bound_names) + -> bale_out_with local_msg + _other -> return (Right name) + + bale_out_with msg + = return (Left (sep [ ptext (sLit "The") <+> what + <+> ptext (sLit "for") <+> quotes (ppr rdr_name) + , nest 2 $ ptext (sLit "lacks an accompanying binding")] + $$ nest 2 msg)) + + local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where") + <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared") + + import_msg = parens $ ptext (sLit "You cannot give a") <+> what + <+> ptext (sLit "for an imported value") + +--------------- +lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name] -- GHC extension: look up both the tycon and data con -- for con-like things -- Complain if neither is in scope -lookupLocalDataTcNames rdr_name +lookupLocalDataTcNames bound_names what 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) - ; case [gre_name gre | Just gre <- mb_gres] of - [] -> do { addErr (unknownNameErr rdr_name) - ; return [] } - names -> return names - } + = do { mb_gres <- mapM (lookupBindGroupOcc (Just bound_names) what) + (dataTcOccs rdr_name) + ; let (errs, names) = splitEithers mb_gres + ; when (null names) (addErr (head errs)) -- Bleat about one only + ; return names } + +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. +dataTcOccs rdr_name + | Just n <- isExact_maybe rdr_name -- Ghastly special case + , n `hasKey` consDataConKey = [rdr_name] -- see note below + | isDataOcc occ = [rdr_name, rdr_name_tc] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + +-- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and setRdrNameSpace generates an Orig, which is fine +-- But it's not fine for (:), because there *is* no corresponding type +-- constructor. If we generate an Orig tycon for GHC.Base.(:), it'll +-- appear to be in scope (because Orig's simply allocate a new name-cache +-- entry) and then we get an error when we use dataTcOccs in +-- TcRnDriver.tcRnGetInfo. Large sigh. +\end{code} + + +%********************************************************* +%* * + Fixities +%* * +%********************************************************* + +\begin{code} +-------------------------------- +type FastStringEnv a = UniqFM a -- Keyed by FastString + + +emptyFsEnv :: FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a + +emptyFsEnv = emptyUFM +lookupFsEnv = lookupUFM +extendFsEnv = addToUFM + +-------------------------------- +type MiniFixityEnv = FastStringEnv (Located Fixity) + -- Mini fixity env for the names we're about + -- to bind, in a single binding group + -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constrctor T + -- + -- We keep the location so that if we find + -- a duplicate, we can report it sensibly -------------------------------- -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 +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl +-- Also check for unused binders +bindLocalNamesFV_WithFixities :: [Name] + -> MiniFixityEnv + -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV_WithFixities names fixities thing_inside + = bindLocalNamesFV names $ + extendFixityEnv boundFixities $ + thing_inside where - rn_sig (FixitySig lv@(L loc v) fix) - = addLocM lookupBndrRn lv `thenM` \ new_v -> - returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) + -- find the names that have fixity decls + boundFixities = foldr + (\ name -> \ acc -> + -- check whether this name has a fixity decl + case lookupFsEnv fixities (occNameFS (nameOccName name)) of + Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc + Nothing -> acc) [] names + -- bind the names; extend the fixity env; do the thing inside \end{code} -------------------------------- @@ -413,13 +688,13 @@ lookupFixity is a bit strange. \begin{code} lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModule `thenM` \ this_mod -> + = 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) - + then do -- It's defined in this module + local_fix_env <- getFixityEnv + traceRn (text "lookupFixityRn: looking up name in local environment:" <+> + vcat [ppr name, ppr local_fix_env]) + return $ lookupFixity local_fix_env name else -- It's imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back @@ -437,40 +712,18 @@ lookupFixityRn name -- -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadInterfaceForName doc name `thenM` \ iface -> - returnM (mi_fix_fn iface (nameOccName name)) + loadInterfaceForName doc name `thenM` \ iface -> do { + traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> + vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]); + returnM (mi_fix_fn iface (nameOccName name)) + } where - doc = ptext SLIT("Checking fixity for") <+> ppr name + doc = ptext (sLit "Checking fixity for") <+> ppr 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 +lookupTyFixityRn (L _ n) = lookupFixityRn n ---------------- -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. -dataTcOccs rdr_name - | Just n <- isExact_maybe rdr_name -- Ghastly special case - , n `hasKey` consDataConKey = [rdr_name] -- see note below - | isDataOcc occ = [rdr_name_tc, rdr_name] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - --- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, --- and setRdrNameSpace generates an Orig, which is fine --- But it's not fine for (:), because there *is* no corresponding type --- constructor. If we generate an Orig tycon for GHC.Base.(:), it'll --- appear to be in scope (because Orig's simply allocate a new name-cache --- entry) and then we get an error when we use dataTcOccs in --- TcRnDriver.tcRnGetInfo. Large sigh. \end{code} %************************************************************************ @@ -501,7 +754,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 @@ -558,26 +811,27 @@ 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 + +--------------------- +checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM () +checkDupAndShadowedRdrNames doc loc_rdr_names + = do { checkDupRdrNames doc loc_rdr_names + ; envs <- getRdrEnvs + ; checkShadowedNames doc envs + [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] } +--------------------- bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [Located RdrName] + -> [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_` + = checkDupAndShadowedRdrNames 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) - + newLocalsRn rdr_names_w_loc `thenM` \names -> + bindLocalNames names (enclosed_scope names) bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope @@ -594,8 +848,8 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -- 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 :: 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) -> @@ -607,13 +861,15 @@ bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] -> RnM a -- Haskell-98 binding of type variables; e.g. within a data type decl bindTyVarsRn doc_str tyvar_names enclosed_scope - = let - located_tyvars = hsLTyVarLocNames 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) + = bindLocatedLocalsRn doc_str located_tyvars $ \ names -> + do { kind_sigs_ok <- doptM Opt_KindSignatures + ; checkM (null kinded_tyvars || kind_sigs_ok) + (mapM_ (addErr . kindSigErr) kinded_tyvars) + ; enclosed_scope (zipWith replace tyvar_names names) } + where + replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2) + located_tyvars = hsLTyVarLocNames tyvar_names + kinded_tyvars = [n | L _ (KindedTyVar n _) <- tyvar_names] bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type @@ -659,27 +915,60 @@ extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- +checkDupRdrNames :: SDoc + -> [Located RdrName] + -> RnM () +checkDupRdrNames doc_str rdr_names_w_loc + = -- Check for duplicated names in a binding group + mappM_ (dupNamesErr getLoc doc_str) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + checkDupNames :: SDoc - -> [Located RdrName] + -> [Name] -> RnM () -checkDupNames doc_str rdr_names_w_loc +checkDupNames doc_str names = -- Check for duplicated names in a binding group - mappM_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr nameSrcSpan doc_str) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names ------------------------------------- -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 )) - = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) - | otherwise = returnM () - in - mappM_ check_shadow loc_rdr_names +checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () +checkShadowedNames doc_str (global_env,local_env) loc_rdr_names + = ifOptM Opt_WarnNameShadowing $ + do { traceRn (text "shadow" <+> ppr loc_rdr_names) + ; mappM_ check_shadow loc_rdr_names } + where + check_shadow (loc, occ) + | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" + -- See Trac #3262 + | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)] + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; complain (map pprNameProvenance gres') } + where + complain [] = return () + complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str occ pp_locs) + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf Trac #2723) + is_shadowed_gre gre@(GRE { gre_par = ParentIs _ }) + = do { dflags <- getDOpts + ; if (dopt Opt_RecordPuns dflags || dopt Opt_RecordWildCards dflags) + then do { is_fld <- is_rec_fld gre; return (not is_fld) } + else return True } + is_shadowed_gre _other = return True + + is_rec_fld gre -- Return True for record selector ids + | isLocalGRE gre = do { RecFields _ fld_set <- getRecFieldEnv + ; return (gre_name gre `elemNameSet` fld_set) } + | otherwise = do { sel_id <- tcLookupField (gre_name gre) + ; return (isRecordSelector sel_id) } \end{code} @@ -691,11 +980,21 @@ checkShadowing doc_str loc_rdr_names \begin{code} -- A useful utility -mapFvRn f xs = mappM f xs `thenM` \ stuff -> - let - (ys, fvs_s) = unzip stuff - in - returnM (ys, plusFVs fvs_s) +mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) +mapFvRn f xs = do stuff <- mappM f xs + case unzip stuff of + (ys, fvs_s) -> returnM (ys, plusFVs fvs_s) + +-- because some of the rename functions are CPSed: +-- maps the function across the list from left to right; +-- collects all the free vars into one set +mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c) + -> [a] -> ([b] -> RnM c) -> RnM c + +mapFvRnCPS _ [] cont = cont [] +mapFvRnCPS f (x:xs) cont = f x $ \ x' -> + mapFvRnCPS f xs $ \ xs' -> + cont (x':xs') \end{code} @@ -710,103 +1009,137 @@ warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) - mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) + 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") + nest 2 (ptext (sLit "except perhaps instances visible in") <+> quotes (ppr m)), - ptext SLIT("To suppress this warning, use:") - <+> ptext SLIT("import") <+> ppr m <> parens empty ] + ptext (sLit "To suppress this warning, use:") + <+> ptext (sLit "import") <+> ppr m <> parens empty ] warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () -warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) -warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () +warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches + +check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () +check_unused flag bound_names used_names + = ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) ------------------------- -- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () 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 :: [Name] -> RnM () 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 -- Otherwise we get a zillion warnings -- from Data.Tuple - | otherwise = reportIfUnused (nameOccName name) + | otherwise = not (startsWithUnderscore (nameOccName name)) ------------------------- -warnUnusedName :: (Name, Maybe Provenance) -> RnM () -warnUnusedName (name, prov) - = addWarnAt loc $ +warnUnusedName :: (Name, Provenance) -> RnM () +warnUnusedName (name, LocalDef) + = addUnusedWarning name (nameSrcSpan 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 -> SrcSpan -> SDoc -> RnM () +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) - = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) +addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () +addNameClashErrRn rdr_name names + = 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] + (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 -shadowedNameWarn doc shadow - = hsep [ptext SLIT("This binding for"), - quotes (ppr shadow), - ptext SLIT("shadows an existing binding")] +shadowedNameWarn :: SDoc -> OccName -> [SDoc] -> SDoc +shadowedNameWarn doc occ shadowed_locs + = sep [ptext (sLit "This binding for") <+> quotes (ppr occ) + <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] $$ doc +unknownNameErr :: RdrName -> SDoc unknownNameErr rdr_name - = sep [ptext SLIT("Not in scope:"), - nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - <+> quotes (ppr rdr_name)] + = vcat [ hang (ptext (sLit "Not in scope:")) + 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + <+> quotes (ppr rdr_name)) + , extra ] + where + extra | rdr_name == forall_tv_RDR = perhapsForallMsg + | otherwise = empty + +perhapsForallMsg :: SDoc +perhapsForallMsg + = vcat [ ptext (sLit "Perhaps you intended to use -XRankNTypes or similar flag") + , ptext (sLit "to enable explicit-forall syntax: forall . ")] -unknownInstBndrErr cls op - = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) +unknownSubordinateErr :: SDoc -> RdrName -> SDoc +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc +badOrigBinding :: RdrName -> SDoc badOrigBinding name - = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr :: SDoc -> [Located RdrName] -> RnM () -dupNamesErr descriptor located_names - = setSrcSpan big_loc $ - addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), - locations, - descriptor]) +dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM () +dupNamesErr get_loc descriptor names + = addErrAt big_loc $ + vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)), + locations, descriptor] where - L _ name1 = head located_names - locs = map getLoc located_names + locs = map get_loc 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:") <+> + | otherwise = ptext (sLit "Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) -infixTyConWarn op - = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), - ftext FSLIT("Use -fglasgow-exts to avoid this warning")] +kindSigErr :: Outputable a => a -> SDoc +kindSigErr thing + = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) + 2 (ptext (sLit "Perhaps you intended to use -XKindSignatures")) + + +badQualBndrErr :: RdrName -> SDoc +badQualBndrErr rdr_name + = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name + +opDeclErr :: RdrName -> SDoc +opDeclErr n + = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n)) + 2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations")) \end{code}