lookupTopFixSigNames, lookupSrcOcc_maybe,
lookupFixityRn, 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,
+ HsType(..), HsExplicitForAll(..), LHsTyVarBndr, LHsType,
+ LSig, Sig(..), Fixity, hsLTyVarName, 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,
isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
Provenance(..), pprNameProvenance, ImportSpec(..)
)
-import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
-import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
- nameSrcLoc, nameOccName, nameModuleName, nameParent )
+import Name ( Name, nameIsLocalOrFrom, mkInternalName,
+ nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
import NameSet
-import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused,
- isVarOcc )
-import Module ( Module, ModuleName, moduleName, mkHomeModule )
-import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey )
+import OccName ( tcName, isDataOcc, occNameFlavour, 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 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}
%*********************************************************
lookupLocatedBndrRn = wrapLocM lookupBndrRn
lookupBndrRn :: RdrName -> RnM Name
--- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd
+-- 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
-- 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) |
-- 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
dataTcOccs :: RdrName -> [RdrName]
-- If the input is a data constructor, return both it and a type
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 = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names]
+ located_tyvars = hsLTyVarLocNames tyvar_names
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope (zipWith replace tyvar_names 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 :: [LSig Name]
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
+-- Bind the top-level forall'd type variables in the sigs.
+-- E.g f :: a -> a
+-- f = rhs
+-- The 'a' scopes over the rhs
+--
+-- NB: there'll usually be just one (for a function binding)
+-- but if there are many, one may shadow the rest; too bad!
+-- e.g x :: [a] -> [a]
+-- y :: [(a,a)] -> a
+-- (x,y) = e
+-- In e, 'a' will be in scope, and it'll be the one from 'y'!
+bindSigTyVarsFV sigs thing_inside
+ = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside
+ else
+ bindLocalNamesFV tvs thing_inside }
+ where
+ tvs = [ hsLTyVarName ltv
+ | L _ (Sig _ (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs, ltv <- ltvs ]
+ -- Note the pattern-match on "Explicit"; we only bind
+ -- type variables from signatures with an explicit top-level for-all
+
+
+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]
check_shadow (L loc rdr_name)
| rdr_name `elemLocalRdrEnv` local_env
|| not (null (lookupGRE_RdrName rdr_name global_env ))
- = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
+ = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
| otherwise = returnM ()
in
mappM_ check_shadow loc_rdr_names
%************************************************************************
\begin{code}
-warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
+warnUnusedModules :: [(Module,SrcSpan)] -> RnM ()
warnUnusedModules mods
= ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
where
- bleat (mod,loc) = addSrcSpan loc $ addWarn (mk_warn mod)
+ 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") <+>
-- 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)
+ -> (is_loc imp_spec, imp_from (is_mod imp_spec))
+ where
+ imp_spec = head is
+ other -> (srcLocSpan (nameSrcLoc name), unused_msg)
unused_msg = text "Defined but not used"
imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used"
= ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
-- The rdrNameOcc is because we don't want to print Prelude.(,)
-dupNamesErr descriptor (L loc name : dup_things)
- = addSrcSpan loc $
- addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
- $$
- descriptor)
+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))
\end{code}