lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
lookupLocatedGlobalOccRn, lookupGlobalOccRn,
- lookupTopFixSigNames, lookupSrcOcc_maybe,
- lookupFixityRn, lookupLocatedSigOccRn,
+ lookupLocalDataTcNames, lookupSrcOcc_maybe,
+ lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
lookupLocatedInstDeclBndr,
- lookupSyntaxName, lookupSyntaxNames, lookupImportedName,
+ lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
bindLocatedLocalsFV, bindLocatedLocalsRn,
- bindPatSigTyVars, bindPatSigTyVarsFV,
+ bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalFixities,
#include "HsVersions.h"
-import LoadIface ( loadSrcInterface )
+import LoadIface ( loadHomeInterface, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
-import HsSyn
+import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable,
+ LHsTyVarBndr, LHsType,
+ Fixity, hsLTyVarLocNames, replaceTyVarName )
import RdrHsSyn ( extractHsTyRdrTyVars )
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
+import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig,
mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
pprGlobalRdrEnv, lookupGRE_RdrName,
isExact_maybe, isSrcRdrName,
GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv,
isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
- Provenance(..), pprNameProvenance, ImportSpec(..)
+ Provenance(..), pprNameProvenance,
+ importSpecLoc, importSpecModule
)
-import HsTypes ( replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
-import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
- nameSrcLoc, nameOccName, nameModuleName, nameParent )
+import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
+ nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
import NameSet
-import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
-import Module ( Module, ModuleName, moduleName, mkHomeModule )
-import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey )
+import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
+ reportIfUnused )
+import Module ( Module )
+import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey )
import UniqSupply
import BasicTypes ( IPName, mapIPName )
import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
- srcLocSpan )
+ srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine )
import Outputable
+import Util ( sortLe )
import ListSetOps ( removeDups )
import List ( nubBy )
-import CmdLineOpts
-import FastString ( FastString )
+import Monad ( when )
+import DynFlags
\end{code}
%*********************************************************
newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name
newTopSrcBinder this_mod mb_parent (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
- -- This is here to catch
+ = -- 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
+ -- 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
+ -- very confused indeed. This test rejects code like
-- data T = (,) Int Int
-- unless we are in GHC.Tup
- = do checkErr (isInternalName name || this_mod_name == nameModuleName name)
+ ASSERT2( isExternalName name, ppr name )
+ do checkErr (this_mod == nameModule name)
(badOrigBinding rdr_name)
returnM name
+
| isOrig rdr_name
- = do checkErr (rdr_mod_name == this_mod_name || rdr_mod_name == rOOT_MAIN_Name)
+ = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(badOrigBinding rdr_name)
-- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad
-- 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_name) (rdrNameOcc rdr_name) mb_parent
+ newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent
(srcSpanStart loc) --TODO, should pass the whole span
| otherwise
= newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc)
where
- this_mod_name = moduleName this_mod
- rdr_mod_name = rdrNameModule rdr_name
+ rdr_mod = rdrNameModule rdr_name
\end{code}
%*********************************************************
-- we don't bother to call newTopSrcBinder first
-- We assume there is no "parent" name
= do { loc <- getSrcSpanM
- ; newGlobalBinder (mkHomeModule (rdrNameModule rdr_name))
+ ; newGlobalBinder (rdrNameModule rdr_name)
(rdrNameOcc rdr_name) Nothing (srcSpanStart loc) }
| otherwise
Nothing ->
-- We allow qualified names on the command line to refer to
- -- *any* name exported by any module in scope, just as if
+ -- *any* name exported by any module in scope, just as if
-- there was an "import qualified M" declaration for every
-- module.
getModule `thenM` \ mod ->
mod = rdrNameModule rdr_name
occ = rdrNameOcc rdr_name
in
+ -- 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 ->
case [ (mod,occ) |
%*********************************************************
\begin{code}
-lookupTopFixSigNames :: RdrName -> RnM [Name]
+lookupLocalDataTcNames :: RdrName -> RnM [Name]
-- GHC extension: look up both the tycon and data con
-- for con-like things
-lookupTopFixSigNames rdr_name
+-- Complain if neither is in scope
+lookupLocalDataTcNames 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] }
+ ; case [gre_name gre | Just gre <- mb_gres] of
+ [] -> do { addErr (unknownNameErr rdr_name)
+ ; return [] }
+ names -> return names
+ }
--------------------------------
bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a
-- 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 ->
+ --
+ -- loadHomeInterface 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))
where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
- name_mod = nameModuleName 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
+
+---------------
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
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
- * NPlusKPatIn
+ * NPlusKPat
* HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
checks the type of the user thing against the type of the standard thing.
\begin{code}
-lookupSyntaxName :: Name -- The standard name
- -> RnM (Name, FreeVars) -- Possibly a non-standard name
+lookupSyntaxName :: Name -- The standard name
+ -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
- if not no_prelude then normal_case
+ = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
+ if implicit_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)
+ returnM (HsVar usr_name, unitFV usr_name)
where
- normal_case = returnM (std_name, emptyFVs)
+ normal_case = returnM (HsVar 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
+lookupSyntaxTable :: [Name] -- Standard names
+ -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
+lookupSyntaxTable std_names
+ = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
+ if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
(enclosed_scope names)
+bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= getLocalRdrEnv `thenM` \ name_env ->
setLocalRdrEnv (extendLocalRdrEnv name_env names)
enclosed_scope
+bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
- = bindLocalNames names $
- enclosed_scope `thenM` \ (thing, fvs) ->
- returnM (thing, delListFromNameSet fvs names)
+ = do { (result, fvs) <- bindLocalNames names enclosed_scope
+ ; returnM (result, delListFromNameSet fvs names) }
-------------------------------------
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
+-- 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
-- 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)
- ]
+ = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside []
+ else
+ do { name_env <- getLocalRdrEnv
+ ; let locd_tvs = [ tv | ty <- tys
+ , tv <- extractHsTyRdrTyVars ty
+ , not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ nubbed_tvs = nubBy eqLocated locd_tvs
-- 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
+ ; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }}
+ where
+ doc_sig = text "In a pattern type-signature"
bindPatSigTyVarsFV :: [LHsType RdrName]
-> RnM (a, FreeVars)
thing_inside `thenM` \ (result,fvs) ->
returnM (result, fvs `delListFromNameSet` tvs)
+bindSigTyVarsFV :: [Name]
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
+bindSigTyVarsFV tvs thing_inside
+ = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside
+ else
+ bindLocalNamesFV tvs thing_inside }
+
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+ -- This function is used only in rnSourceDecl on InstDecl
+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
+
-------------------------------------
checkDupNames :: SDoc
-> [Located RdrName]
%************************************************************************
\begin{code}
-warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
+warnUnusedModules :: [(Module,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) <+>
- text "is imported, but nothing from it is used",
- parens (ptext SLIT("except perhaps instances visible in") <+>
- quotes (ppr m))]
+ 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")
+ <+> quotes (ppr m)),
+ 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)
warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM ()
warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names)
- where reportable (name,_) = reportIfUnused (nameOccName name)
+ 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)
-------------------------
warnUnusedName (name, prov)
= addWarnAt loc $
sep [msg <> colon,
- nest 2 $ occNameFlavour (nameOccName name) <+> quotes (ppr name)]
+ nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
+ <+> quotes (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 )
+ 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"
unknownNameErr rdr_name
= sep [ptext SLIT("Not in scope:"),
- nest 2 $ occNameFlavour (rdrNameOcc rdr_name) <+> quotes (ppr 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)
= 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)
- = setSrcSpan loc $
- addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
- $$
- descriptor)
+dupNamesErr :: SDoc -> [Located RdrName] -> RnM ()
+dupNamesErr descriptor located_names
+ = setSrcSpan big_loc $
+ addErr (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
+ 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")]
\end{code}
projects / ghc-hetmet.git / blobdiff