\begin{code}
module RnEnv (
- newTopSrcBinder,
+ newTopSrcBinder, lookupFamInstDeclBndr,
lookupLocatedBndrRn, lookupBndrRn,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
lookupLocatedInstDeclBndr,
lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
+ lookupGreRn,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
import UniqSupply
import BasicTypes ( IPName, mapIPName )
import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
- srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine )
+ srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
import Outputable
import Util ( sortLe )
import ListSetOps ( removeDups )
-- 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
--
-- 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 mb_parent (srcSpanStart 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
+ ; newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) }
\end{code}
%*********************************************************
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)
+ | not (isSrcRdrName rdr_name)
+ = lookupImportedName rdr_name
+
+ | otherwise
+ = -- First look up the name in the normal environment.
+ lookupGreRn rdr_name `thenM` \ mb_gre ->
+ case mb_gre of {
+ Just gre -> returnM (gre_name gre) ;
+ Nothing -> newTopSrcBinder mod Nothing lrdr_name }
+
--------------------------------------------------
-- Occurrences
--------------------------------------------------
---------------
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
+ = do { glaExts <- doptM Opt_GlasgowExts
+ ; when (not glaExts) (addWarnAt loc (infixTyConWarn n))
+ ; lookupFixityRn n }
---------------
dataTcOccs :: RdrName -> [RdrName]
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)
+ = addWarnAt loc (shadowedNameWarn doc_str rdr_name)
| otherwise = returnM ()
in
mappM_ check_shadow loc_rdr_names
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")
\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
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))
+badQualBndrErr rdr_name
+ = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name
+
infixTyConWarn op
= vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op),
ftext FSLIT("Use -fglasgow-exts to avoid this warning")]