X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=66177a90aa370b01cb1b1b87c684ca4e9dadeef2;hp=2be3bfd5c0b464e30c0a1ca339365b931f612b09;hb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 2be3bfd..66177a9 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,28 +1,37 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +\% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 % \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module RnEnv ( - newTopSrcBinder, - lookupLocatedBndrRn, lookupBndrRn, - lookupLocatedTopBndrRn, lookupTopBndrRn, + newTopSrcBinder, lookupFamInstDeclBndr, + lookupLocatedBndrRn, lookupBndrRn, lookupBndrRn_maybe, + lookupLocatedTopBndrRn, lookupTopBndrRn, lookupBndrRn_maybe, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, - lookupLocatedInstDeclBndr, + lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, + lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, + getLookupOccRn, newLocalsRn, newIPNameRn, - bindLocalNames, bindLocalNamesFV, + bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, - checkDupNames, mapFvRn, + checkDupNames, checkShadowing, mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, @@ -30,40 +39,48 @@ module RnEnv ( #include "HsVersions.h" -import LoadIface ( loadHomeInterface, loadSrcInterface ) +import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, LHsTyVarBndr, LHsType, Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, +import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, + isQual_maybe, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, isExact_maybe, isSrcRdrName, + Parent(..), GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, Provenance(..), pprNameProvenance, importSpecLoc, importSpecModule ) -import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) +import TcEnv ( tcLookupDataCon ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) + nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet +import NameEnv +import UniqFM +import DataCon ( dataConFieldLabels ) import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, - reportIfUnused ) -import Module ( Module ) + reportIfUnused, occNameFS ) +import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply -import BasicTypes ( IPName, mapIPName ) +import BasicTypes ( IPName, mapIPName, Fixity ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) + srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable -import Util ( sortLe ) +import Util +import Maybes import ListSetOps ( removeDups ) import List ( nubBy ) import Monad ( when ) import DynFlags +import FastString \end{code} %********************************************************* @@ -73,8 +90,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 @@ -86,14 +103,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 } - | isOrig rdr_name - = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (badOrigBinding rdr_name) + | Just (rdr_mod, rdr_occ) <- isOrig_maybe 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 -- @@ -111,13 +128,15 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalBinder rdr_mod (rdrNameOcc rdr_name) 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) - where - rdr_mod = rdrNameModule rdr_name + = do { checkM (not (isQual rdr_name)) + (addErrAt loc (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we we get a confusing "M.T is not in scope" error later + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } \end{code} %********************************************************* @@ -133,17 +152,31 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedBndrRn = wrapLocM lookupBndrRn lookupBndrRn :: RdrName -> RnM Name +lookupBndrRn n = do nopt <- lookupBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ text "lookupTopBndrRn" + unboundName n + +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 + +lookupBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd -lookupBndrRn rdr_name +lookupBndrRn_maybe rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of - Just name -> returnM name - Nothing -> lookupTopBndrRn rdr_name + Just name -> returnM (Just name) + Nothing -> lookupTopBndrRn_maybe rdr_name 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: @@ -160,23 +193,23 @@ 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) - | isOrig rdr_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 (rdrNameModule rdr_name) - (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } + ; n <- newGlobalBinder rdr_mod rdr_occ loc + ; return (Just n)} | otherwise = do { 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? @@ -188,28 +221,107 @@ lookupTopBndrRn rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn +-- +-- However, consider this case: +-- import M( f ) +-- f :: Int -> Int +-- g x = x +-- We don't want to say 'f' is out of scope; instead, we want to +-- return the imported 'f', so that later on the reanamer will +-- correctly report "misplaced type sig". lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedSigOccRn = lookupLocatedBndrRn - --- lookupInstDeclBndr is used for the binders in an --- instance declaration. Here we use the class name to --- disambiguate. +lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do + { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of { + Just n -> return n ; + Nothing -> do + { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Just gre -> return (gre_name gre) + Nothing -> lookupGlobalOccRn rdr_name + }}} + +----------------------------------------------- +lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr + where + doc = ptext SLIT("method of class") <+> quotes (ppr cls) + is_op gre@(GRE {gre_par = ParentIs n}) = n == cls + is_op other = False + +----------------------------------------------- +lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name) +-- Used for record construction and pattern matching +-- When the -fdisambiguate-record-fields flag is on, take account of the +-- constructor name to disambiguate which field to use; it's just the +-- same as for instance decls +lookupRecordBndr Nothing rdr_name + = lookupLocatedGlobalOccRn rdr_name +lookupRecordBndr (Just (L _ data_con)) rdr_name + = do { flag_on <- doptM Opt_DisambiguateRecordFields + ; if not flag_on + then lookupLocatedGlobalOccRn rdr_name + else do { + fields <- lookupConstructorFields data_con + ; let is_field gre = gre_name gre `elem` fields + ; lookup_located_sub_bndr is_field doc rdr_name + }} + where + doc = ptext SLIT("field of constructor") <+> quotes (ppr data_con) + + +lookupConstructorFields :: Name -> RnM [Name] +-- Look up the fields of a given constructor +-- * For constructors from this module, use the record field env, +-- which is itself gathered from the (as yet un-typechecked) +-- data type decls +-- +-- * For constructors from imported modules, use the *type* environment +-- since imported modles are already compiled, the info is conveniently +-- right there + +lookupConstructorFields con_name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod con_name then + do { field_env <- getRecFieldEnv + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupDataCon con_name + ; return (dataConFieldLabels con) } } -lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) +----------------------------------------------- +lookup_located_sub_bndr :: (GlobalRdrElt -> Bool) + -> SDoc -> Located RdrName + -> RnM (Located Name) +lookup_located_sub_bndr is_good doc rdr_name + = wrapLocM (lookup_sub_bndr is_good doc) rdr_name -lookupInstDeclBndr :: Name -> RdrName -> RnM Name -lookupInstDeclBndr cls_name rdr_name +lookup_sub_bndr is_good doc rdr_name | isUnqual rdr_name -- Find all the things the rdr-name maps to = do { -- and pick the one with the right parent name - let { is_op gre = cls_name == nameParent (gre_name gre) - ; occ = rdrNameOcc rdr_name - ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } - ; mb_gre <- lookupGreRn_help rdr_name lookup_fn - ; case mb_gre of - Just gre -> return (gre_name gre) - Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) - ; return (mkUnboundName rdr_name) } } + ; env <- getGlobalRdrEnv + ; case filter is_good (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) of + -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! + -- The latter does pickGREs, but we want to allow 'x' + -- even if only 'M.x' is in scope + [gre] -> return (gre_name gre) + [] -> do { addErr (unknownSubordinateErr doc rdr_name) + ; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name) + ; return (mkUnboundName rdr_name) } + gres -> do { addNameClashErrRn rdr_name gres + ; return (gre_name (head gres)) } + } | otherwise -- Occurs in derived instances, where we just -- refer directly to the right method @@ -220,10 +332,32 @@ lookupInstDeclBndr cls_name rdr_name newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) +-- Looking up family names in type instances is a subtle affair. The family +-- may be imported, in which case we need to lookup the occurence of a global +-- name. Alternatively, the family may be in the same binding group (and in +-- fact in a declaration processed later), and we need to create a new top +-- source binder. +-- +-- So, also this is strictly speaking an occurence, we cannot raise an error +-- message yet for instances without a family declaration. This will happen +-- during renaming the type instance declaration in RnSource.rnTyClDecl. +-- +lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name +lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of + Just gre -> returnM (gre_name gre) ; + Nothing -> newTopSrcBinder mod lrdr_name } + -------------------------------------------------- -- Occurrences -------------------------------------------------- +getLookupOccRn :: RnM (Name -> Maybe Name) +getLookupOccRn + = getLocalRdrEnv `thenM` \ local_env -> + return (lookupLocalRdrEnv local_env . mkRdrUnqual . nameOccName) + lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -250,7 +384,7 @@ lookupGlobalOccRn rdr_name | otherwise = -- First look up the name in the normal environment. - lookupGreRn rdr_name `thenM` \ mb_gre -> + lookupGreRn_maybe rdr_name `thenM` \ mb_gre -> case mb_gre of { Just gre -> returnM (gre_name gre) ; Nothing -> @@ -263,7 +397,8 @@ lookupGlobalOccRn rdr_name if isQual rdr_name && mod == iNTERACTIVE then -- This test is not expensive, lookupQualifiedName rdr_name -- and only happens for failed lookups - else + else do + traceRn $ text "lookupGlobalOccRn" unboundName rdr_name } lookupImportedName :: RdrName -> TcRnIf m n Name @@ -278,9 +413,12 @@ lookupImportedName 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) + -- Always Orig, even when reading a .hi-boot file + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = lookupOrig rdr_mod rdr_occ + + | otherwise + = pprPanic "RnEnv.lookupImportedName" (ppr rdr_name) unboundName :: RdrName -> RnM Name unboundName rdr_name @@ -298,17 +436,29 @@ unboundName rdr_name lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name) -- No filter function; does not report an error on failure lookupSrcOcc_maybe rdr_name - = do { mb_gre <- lookupGreRn rdr_name + = do { mb_gre <- lookupGreRn_maybe rdr_name ; case mb_gre of Nothing -> returnM Nothing Just gre -> returnM (Just (gre_name gre)) } ------------------------- -lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) -- Just look up the RdrName in the GlobalRdrEnv -lookupGreRn rdr_name +lookupGreRn_maybe rdr_name = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) +lookupGreRn :: RdrName -> RnM GlobalRdrElt +-- If not found, add error message, and return a fake GRE +lookupGreRn rdr_name + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of { + Just gre -> return gre ; + Nothing -> do + { traceRn $ text "lookupGreRn" + ; name <- unboundName rdr_name + ; return (GRE { gre_name = name, gre_par = NoParent, + gre_prov = LocalDef }) }}} + lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) -- Similar, but restricted to locally-defined things lookupGreLocalRn rdr_name @@ -337,13 +487,10 @@ lookupGreRn_help rdr_name lookup -- 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 + | 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 `thenM` \ iface -> case [ (mod,occ) | (mod,avails) <- mi_exports iface, @@ -353,6 +500,9 @@ lookupQualifiedName rdr_name ((mod,occ):ns) -> ASSERT (null ns) lookupOrig mod occ _ -> unboundName rdr_name + + | otherwise + = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) where doc = ptext SLIT("Need to find") <+> ppr rdr_name \end{code} @@ -375,24 +525,62 @@ lookupLocalDataTcNames rdr_name | otherwise = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) ; case [gre_name gre | Just gre <- mb_gres] of - [] -> do { addErr (unknownNameErr rdr_name) - ; return [] } + [] -> do { + -- run for error reporting + ; unboundName rdr_name + ; return [] } names -> return names } -------------------------------- -bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a --- Used for nested fixity decls +bindLocalFixities :: [FixitySig RdrName] -> (UniqFM (Located Fixity) -> RnM a) -> RnM a +-- Used for nested fixity decls: +-- bind the names that are in scope already; +-- pass the rest to the continuation for later +-- as a FastString->(Located Fixity) map +-- -- No need to worry about type constructors here, --- Should check for duplicates but we don't +-- Should check for duplicates? bindLocalFixities fixes thing_inside - | null fixes = thing_inside - | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> - extendFixityEnv new_bit thing_inside + | null fixes = thing_inside emptyUFM + | otherwise = do ls <- mappM rn_sig fixes + let (now, later) = nowAndLater ls + extendFixityEnv now $ thing_inside later where - rn_sig (FixitySig lv@(L loc v) fix) - = addLocM lookupBndrRn lv `thenM` \ new_v -> - returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) + rn_sig (FixitySig lv@(L loc v) fix) = do + vopt <- lookupBndrRn_maybe v + case vopt of + Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix))) + Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix))) + + nowAndLater :: [Either (Name, FixItem) (FastString, Located Fixity)] + -> ([(Name,FixItem)], UniqFM (Located Fixity)) + nowAndLater ls = + foldr (\ cur -> \ (now, later) -> + case cur of + Left (n, f) -> ((n, f) : now, later) + Right (fs, f) -> (now, addToUFM later fs f)) + ([], emptyUFM) ls + +-- 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] + -> UniqFM (Located Fixity) + -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV_WithFixities names fixities thing_inside + = bindLocalNamesFV names $ + extendFixityEnv boundFixities $ + thing_inside + where + -- find the names that have fixity decls + boundFixities = foldr + (\ name -> \ acc -> + -- check whether this name has a fixity decl + case lookupUFM 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} -------------------------------- @@ -412,16 +600,16 @@ 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 - -- loadHomeInterface, and consulting the Ifaces that comes back + -- loadInterfaceForName, 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; @@ -434,20 +622,19 @@ lookupFixityRn name -- '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. -- - -- loadHomeInterface will find B.hi even if B is a hidden module, + -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadHomeInterface 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 --------------- 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 loc n) = lookupFixityRn n --------------- dataTcOccs :: RdrName -> [RdrName] @@ -500,7 +687,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 @@ -557,26 +744,22 @@ newLocalsRn rdr_names_w_loc | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) -- We only bind unqualified names here -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) + mkInternalName uniq (rdrNameOcc rdr_name) loc bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [Located RdrName] + -> [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_` + -- Warn about shadowing + 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) - + newLocalsRn rdr_names_w_loc `thenM` \names -> + bindLocalNames names (enclosed_scope names) bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope @@ -593,8 +776,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) -> @@ -669,16 +852,20 @@ checkDupNames doc_str rdr_names_w_loc ------------------------------------- checkShadowing doc_str loc_rdr_names - = getLocalRdrEnv `thenM` \ local_env -> + = traceRn (text "shadow" <+> ppr loc_rdr_names) `thenM_` + 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 () + | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)] + | not (null gres) = complain (map pprNameProvenance gres) + | otherwise = return () + where + complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str rdr_name pp_locs) + mb_local = lookupLocalRdrEnv local_env rdr_name + gres = lookupGRE_RdrName rdr_name global_env in - mappM_ check_shadow loc_rdr_names + ifOptM Opt_WarnNameShadowing (mappM_ check_shadow loc_rdr_names) \end{code} @@ -695,6 +882,17 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> (ys, fvs_s) = unzip stuff in 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} @@ -705,11 +903,11 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [(Module,SrcSpan)] -> RnM () +warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) + bleat (mod,loc) = addWarnAt loc (mk_warn mod) mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used,", nest 2 (ptext SLIT("except perhaps instances visible in") @@ -722,19 +920,29 @@ 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] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches + +check_unused :: DynFlag -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +check_unused flag names thing_inside + = do { (res, res_fvs) <- thing_inside + + -- Warn about unused names + ; ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` res_fvs) names)) + + -- And return + ; return (res, res_fvs) } ------------------------- -- Helpers warnUnusedGREs gres - = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] + = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] warnUnusedLocals names - = warnUnusedBinds [(n,Nothing) | n<-names] + = warnUnusedBinds [(n,LocalDef) | n<-names] -warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds :: [(Name,Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) where reportable (name,_) | isWiredInName name = False -- Don't report unused wired-in names @@ -744,38 +952,41 @@ warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) ------------------------- -warnUnusedName :: (Name, Maybe Provenance) -> RnM () -warnUnusedName (name, prov) - = addWarnAt loc $ +warnUnusedName :: (Name, Provenance) -> RnM () +warnUnusedName (name, LocalDef) + = addUnusedWarning name (srcLocSpan (nameSrcLoc name)) + (ptext SLIT("Defined but not used")) + +warnUnusedName (name, Imported is) + = mapM_ warn is + where + warn spec = addUnusedWarning name span msg + where + span = importSpecLoc spec + pp_mod = quotes (ppr (importSpecModule spec)) + msg = ptext SLIT("Imported from") <+> pp_mod <+> ptext SLIT("but not used") + +addUnusedWarning name span msg + = addWarnAt span $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> quotes (ppr name)] - -- TODO should be a proper span - where - (loc,msg) = case prov of - Just (Imported is) - -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec)) - where - imp_spec = head is - other -> (srcLocSpan (nameSrcLoc name), unused_msg) - - unused_msg = text "Defined but not used" - imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" \end{code} \begin{code} -addNameClashErrRn rdr_name (np1:nps) +addNameClashErrRn rdr_name names = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where + (np1:nps) = names msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn doc shadow - = hsep [ptext SLIT("This binding for"), - quotes (ppr shadow), - ptext SLIT("shadows an existing binding")] +shadowedNameWarn doc rdr_name shadowed_locs + = sep [ptext SLIT("This binding for") <+> quotes (ppr rdr_name) + <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] $$ doc unknownNameErr rdr_name @@ -783,8 +994,9 @@ unknownNameErr rdr_name nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) <+> quotes (ppr rdr_name)] -unknownInstBndrErr cls op - = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> ptext SLIT("is not a (visible)") <+> doc badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) @@ -792,20 +1004,18 @@ badOrigBinding name dupNamesErr :: SDoc -> [Located RdrName] -> RnM () dupNamesErr descriptor located_names - = setSrcSpan big_loc $ - addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), - locations, - descriptor]) + = addErrAt big_loc $ + vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + locations, descriptor] where L _ name1 = head located_names locs = map getLoc located_names big_loc = foldr1 combineSrcSpans locs - one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc + one_line = isOneLineSpan big_loc locations | one_line = empty | otherwise = ptext SLIT("Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) -infixTyConWarn op - = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), - ftext FSLIT("Use -fglasgow-exts to avoid this warning")] +badQualBndrErr rdr_name + = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name \end{code}