module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
lookupLocalOccRn_maybe, lookupInfoOccRn,
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
reportUnboundName,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
greRdrName,
lookupSubBndrGREs, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
lookupGreRn, lookupGreRn_maybe,
lookupGreLocalRn_maybe,
getLookupOccRn, addUsedRdrNames,
newLocalBndrRn, newLocalBndrsRn,
bindLocalNames, bindLocalNamesFV,
MiniFixityEnv,
addLocalFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
extendTyVarEnvFVRn,
checkDupRdrNames, checkShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames, checkTupSize,
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, kindSigErr, perhapsForallMsg,
HsDocContext(..), docOfHsDocContext
) where
#include "HsVersions.h"
import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe )
import IfaceEnv
import HsSyn
import RdrName
import HscTypes
import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage )
import TcRnMonad
import Id ( isRecordSelector )
import Name
import NameSet
import NameEnv
import Avail
import Module
import ConLike
import DataCon ( dataConFieldLabels, dataConTyCon )
import TyCon ( isTupleTyCon, tyConArity )
import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
import ErrUtils ( MsgDoc )
import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity )
import SrcLoc
import Outputable
import Util
import Maybes
import BasicTypes ( TopLevelFlag(..) )
import ListSetOps ( removeDups )
import DynFlags
import FastString
import Control.Monad
import Data.List
import qualified Data.Set as Set
import ListSetOps ( minusList )
import Constants ( mAX_TUPLE_SIZE )
newTopSrcBinder :: Located RdrName -> RnM Name
newTopSrcBinder (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
=
if isExternalName name then
do { this_mod <- getModule
; unless (this_mod == nameModule name)
(addErrAt loc (badOrigBinding rdr_name))
; return name }
else
do { let occ = nameOccName name
; occ `seq` return ()
; this_mod <- getModule
; updNameCache $ \ ns ->
let name' = mkExternalName (nameUnique name) this_mod occ loc
ns' = ns { nsNames = extendNameCache (nsNames ns) this_mod occ name' }
in (ns', name') }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { this_mod <- getModule
; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(addErrAt loc (badOrigBinding rdr_name))
; newGlobalBinder rdr_mod rdr_occ loc }
| otherwise
= do { unless (not (isQual rdr_name))
(addErrAt loc (badQualBndrErr rdr_name))
; stage <- getStage
; env <- getGblEnv
; if isBrackStage stage then
do { uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
else case tcg_impl_rdr_env env of
Just gr ->
do { case lookupGlobalRdrEnv gr (rdrNameOcc rdr_name) of
[GRE{ gre_name = n }] -> do
return (setNameLoc n loc)
_ -> do
{
; addErr (unknownNameErr (pprNonVarNameSpace
(occNameSpace (rdrNameOcc rdr_name))) rdr_name)
; return (mkUnboundName rdr_name)
}
}
Nothing ->
do { this_mod <- getModule
; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } }
lookupTopBndrRn :: RdrName -> RnM Name
lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
case nopt of
Just n' -> return n'
Nothing -> do traceRn $ (text "lookupTopBndrRn fail" <+> ppr n)
unboundName WL_LocalTop n
lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
lookupTopBndrRn_maybe rdr_name
| Just name <- isExact_maybe rdr_name
= do { name' <- lookupExactOcc name; return (Just name') }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { loc <- getSrcSpanM
; n <- newGlobalBinder rdr_mod rdr_occ loc
; return (Just n)}
| otherwise
= do {
let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ)
(do { op_ok <- xoptM Opt_TypeOperators
; unless op_ok (addErr (opDeclErr rdr_name)) })
; mb_gre <- lookupGreLocalRn_maybe rdr_name
; case mb_gre of
Nothing -> return Nothing
Just gre -> return (Just $ gre_name gre) }
lookupExactOcc :: Name -> RnM Name
lookupExactOcc name
= do { result <- lookupExactOcc_either name
; case result of
Left err -> do { addErr err
; return name }
Right name' -> return name' }
lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)
lookupExactOcc_either name
| Just thing <- wiredInNameTyThing_maybe name
, Just tycon <- case thing of
ATyCon tc -> Just tc
AConLike (RealDataCon dc) -> Just (dataConTyCon dc)
_ -> Nothing
, isTupleTyCon tycon
= do { checkTupSize (tyConArity tycon)
; return (Right name) }
| isExternalName name
= return (Right name)
| otherwise
= do { env <- getGlobalRdrEnv
; let
main_occ = nameOccName name
demoted_occs = case demoteOccName main_occ of
Just occ -> [occ]
Nothing -> []
gres = [ gre | occ <- main_occ : demoted_occs
, gre <- lookupGlobalRdrEnv env occ
, gre_name gre == name ]
; case gres of
[] ->
do { lcl_env <- getLocalRdrEnv
; if name `inLocalRdrEnvScope` lcl_env
then return (Right name)
else
#ifdef GHCI
do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
; th_topnames <- readTcRef th_topnames_var
; if name `elemNameSet` th_topnames
then return (Right name)
else return (Left exact_nm_err)
}
#else /* !GHCI */
return (Left exact_nm_err)
#endif /* !GHCI */
}
[gre] -> return (Right (gre_name gre))
_ -> return (Left dup_nm_err)
}
where
exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ")
, ptext (sLit "perhaps via newName, but did not bind it")
, ptext (sLit "If that's it, then -ddump-splices might be useful") ])
dup_nm_err = hang (ptext (sLit "Duplicate exact Name") <+> quotes (ppr $ nameOccName name))
2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ")
, ptext (sLit "perhaps via newName, but bound it multiple times")
, ptext (sLit "If that's it, then -ddump-splices might be useful") ])
lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name
lookupInstDeclBndr cls what rdr
= do { when (isQual rdr)
(addErr (badQualBndrErr rdr))
; lookupSubBndrOcc False
(ParentIs cls) doc rdr }
where
doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)
lookupFamInstName (Just cls) tc_rdr
= wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
lookupFamInstName Nothing tc_rdr
= lookupLocatedOccRn tc_rdr
lookupConstructorFields :: Name -> RnM [Name]
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) } }
lookupSubBndrOcc :: Bool
-> Parent
-> SDoc -> RdrName
-> RnM Name
lookupSubBndrOcc warnIfDeprec parent doc rdr_name
| Just n <- isExact_maybe rdr_name
= lookupExactOcc n
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= lookupOrig rdr_mod rdr_occ
| otherwise
= do {
env <- getGlobalRdrEnv
; case lookupSubBndrGREs env parent rdr_name of
[gre] -> do { addUsedRdrName warnIfDeprec gre (used_rdr_name gre)
; return (gre_name gre) }
[] -> do { addErr (unknownSubordinateErr doc rdr_name)
; return (mkUnboundName rdr_name) }
gres -> do { addNameClashErrRn rdr_name gres
; return (gre_name (head gres)) } }
where
used_rdr_name gre
| isQual rdr_name = rdr_name
| otherwise = greRdrName gre
greRdrName :: GlobalRdrElt -> RdrName
greRdrName gre
= case gre_prov gre of
LocalDef -> unqual_rdr
Imported is -> used_rdr_name_from_is is
where
occ = nameOccName (gre_name gre)
unqual_rdr = mkRdrUnqual occ
used_rdr_name_from_is imp_specs
| not (all (is_qual . is_decl) imp_specs)
= unqual_rdr
| otherwise
=
ASSERT( not (null imp_specs) )
mkRdrQual (is_as (is_decl (head imp_specs))) occ
lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt]
lookupSubBndrGREs env parent rdr_name
= case parent of
NoParent -> pickGREs rdr_name gres
ParentIs p
| isUnqual rdr_name -> filter (parent_is p) gres
| otherwise -> filter (parent_is p) (pickGREs rdr_name gres)
where
gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
parent_is _ _ = False
getLookupOccRn :: RnM (Name -> Maybe Name)
getLookupOccRn
= do local_env <- getLocalRdrEnv
return (lookupLocalRdrOcc local_env . nameOccName)
lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
lookupLocatedOccRn = wrapLocM lookupOccRn
lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
lookupLocalOccThLvl_maybe name
= do { lcl_env <- getLclEnv
; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of
Just name -> return name
Nothing -> reportUnboundName rdr_name }
lookupKindOccRn :: RdrName -> RnM Name
lookupKindOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of
Just name -> return name
Nothing -> reportUnboundName rdr_name }
lookupTypeOccRn :: RdrName -> RnM Name
lookupTypeOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of {
Just name -> return name ;
Nothing -> lookup_demoted rdr_name } }
lookup_demoted :: RdrName -> RnM Name
lookup_demoted rdr_name
| Just demoted_rdr <- demoteRdrName rdr_name
= do { data_kinds <- xoptM Opt_DataKinds
; mb_demoted_name <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_name of
Nothing -> reportUnboundName rdr_name
Just demoted_name
| data_kinds ->
do { whenWOptM Opt_WarnUntickedPromotedConstructors $
addWarn (untickedPromConstrWarn demoted_name)
; return demoted_name }
| otherwise -> unboundNameX WL_Any rdr_name suggest_dk }
| otherwise
= reportUnboundName rdr_name
where
suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean DataKinds?")
untickedPromConstrWarn name =
text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot
$$
hsep [ text "Use"
, quotes (char '\'' <> ppr name)
, text "instead of"
, quotes (ppr name) <> dot ]
lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
Just name -> return (Just name) ;
Nothing -> do
{ mb_name <- lookupGlobalOccRn_maybe rdr_name
; case mb_name of {
Just name -> return (Just name) ;
Nothing -> do
{ ns <- lookupQualifiedNameGHCi rdr_name
; case ns of
(n:_) -> return (Just n)
[] -> return Nothing } } } } }
lookupGlobalOccRn :: RdrName -> RnM Name
lookupGlobalOccRn rdr_name
= do { mb_name <- lookupGlobalOccRn_maybe rdr_name
; case mb_name of
Just n -> return n
Nothing -> do { traceRn (text "lookupGlobalOccRn" <+> ppr rdr_name)
; unboundName WL_Global rdr_name } }
lookupInfoOccRn :: RdrName -> RnM [Name]
lookupInfoOccRn rdr_name
| Just n <- isExact_maybe rdr_name
= return [n]
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { n <- lookupOrig rdr_mod rdr_occ
; return [n] }
| otherwise
= do { rdr_env <- getGlobalRdrEnv
; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)
; qual_ns <- lookupQualifiedNameGHCi rdr_name
; return (ns ++ (qual_ns `minusList` ns)) }
lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupGlobalOccRn_maybe rdr_name
| Just n <- isExact_maybe rdr_name
= do { n' <- lookupExactOcc n; return (Just n') }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { n <- lookupOrig rdr_mod rdr_occ
; return (Just n) }
| otherwise
= do { mb_gre <- lookupGreRn_maybe rdr_name
; case mb_gre of
Nothing -> return Nothing
Just gre -> return (Just (gre_name gre)) }
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreRn_maybe rdr_name
= lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
lookupGreRn :: RdrName -> RnM GlobalRdrElt
lookupGreRn rdr_name
= do { mb_gre <- lookupGreRn_maybe rdr_name
; case mb_gre of {
Just gre -> return gre ;
Nothing -> do
{ traceRn (text "lookupGreRn" <+> ppr rdr_name)
; name <- unboundName WL_Global rdr_name
; return (GRE { gre_name = name, gre_par = NoParent,
gre_prov = LocalDef }) }}}
lookupGreLocalRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreLocalRn_maybe rdr_name
= lookupGreRn_help rdr_name lookup_fn
where
lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env)
lookupGreRn_help :: RdrName
-> (GlobalRdrEnv -> [GlobalRdrElt])
-> RnM (Maybe GlobalRdrElt)
lookupGreRn_help rdr_name lookup
= do { env <- getGlobalRdrEnv
; case lookup env of
[] -> return Nothing
[gre] -> do { addUsedRdrName True gre rdr_name
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; return (Just (head gres)) } }
addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM ()
addUsedRdrName warnIfDeprec gre rdr
| isLocalGRE gre = return ()
| otherwise = do { env <- getGblEnv
; when warnIfDeprec $ warnIfDeprecated gre
; 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) }
warnIfDeprecated :: GlobalRdrElt -> RnM ()
warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) })
= do { dflags <- getDynFlags
; when (wopt Opt_WarnWarningsDeprecations dflags) $
do { iface <- loadInterfaceForName doc name
; case lookupImpDeprec iface gre of
Just txt -> addWarn (mk_msg txt)
Nothing -> return () } }
where
mk_msg txt = sep [ sep [ ptext (sLit "In the use of")
<+> pprNonVarNameSpace (occNameSpace (nameOccName name))
<+> quotes (ppr name)
, parens imp_msg <> colon ]
, ppr txt ]
name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
imp_mod = importSpecModule imp_spec
imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra
extra | imp_mod == moduleName name_mod = Outputable.empty
| otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly")
warnIfDeprecated _ = return ()
lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
lookupImpDeprec iface gre
= mi_warn_fn iface (gre_name gre) `mplus`
case gre_par gre of
ParentIs p -> mi_warn_fn iface p
NoParent -> Nothing
lookupQualifiedNameGHCi :: RdrName -> RnM [Name]
lookupQualifiedNameGHCi rdr_name
=
do { dflags <- getDynFlags
; is_ghci <- getIsGHCi
; go_for_it dflags is_ghci }
where
go_for_it dflags is_ghci
| Just (mod,occ) <- isQual_maybe rdr_name
, is_ghci
, gopt Opt_ImplicitImportQualified dflags
, not (safeDirectImpsReq dflags)
= do { res <- loadSrcInterface_maybe doc mod False Nothing
; case res of
Succeeded ifaces
-> return [ name
| iface <- ifaces
, avail <- mi_exports iface
, name <- availNames avail
, nameOccName name == occ ]
_ ->
do { traceRn (text "lookupQualifiedNameGHCi" <+> ppr rdr_name)
; return [] } }
| otherwise
= return []
doc = ptext (sLit "Need to find") <+> ppr rdr_name
data HsSigCtxt
= TopSigCtxt NameSet Bool
| LocalBindCtxt NameSet
| ClsDeclCtxt Name
| InstDeclCtxt Name
| HsBootCtxt
lookupSigOccRn :: HsSigCtxt
-> Sig RdrName
-> Located RdrName -> RnM (Located Name)
lookupSigOccRn ctxt sig
= wrapLocM $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc ctxt (hsSigDoc sig) rdr_name
; case mb_name of
Left err -> do { addErr err; return (mkUnboundName rdr_name) }
Right name -> return name }
lookupBindGroupOcc :: HsSigCtxt
-> SDoc
-> RdrName -> RnM (Either MsgDoc Name)
lookupBindGroupOcc ctxt what rdr_name
| Just n <- isExact_maybe rdr_name
= lookupExactOcc_either n
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { n' <- lookupOrig rdr_mod rdr_occ
; return (Right n') }
| otherwise
= case ctxt of
HsBootCtxt -> lookup_top (const True) True
TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls
InstDeclCtxt cls -> lookup_cls_op cls
where
lookup_cls_op cls
= do { env <- getGlobalRdrEnv
; let gres = lookupSubBndrGREs env (ParentIs cls) rdr_name
; case gres of
[] -> return (Left (unknownSubordinateErr doc rdr_name))
(gre:_) -> return (Right (gre_name gre)) }
where
doc = ptext (sLit "method of class") <+> quotes (ppr cls)
lookup_top keep_me meth_ok
= do { env <- getGlobalRdrEnv
; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; case filter (keep_me . gre_name) all_gres of
[] | null all_gres -> bale_out_with Outputable.empty
| otherwise -> bale_out_with local_msg
(gre:_)
| ParentIs {} <- gre_par gre
, not meth_ok
-> bale_out_with sub_msg
| otherwise
-> return (Right (gre_name gre)) }
lookup_group bound_names
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of
Just n
| n `elemNameSet` bound_names -> return (Right n)
| otherwise -> bale_out_with local_msg
Nothing -> bale_out_with Outputable.empty }
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")
sub_msg = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for a record selector or class method")
lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
lookupLocalTcNames ctxt what rdr_name
= do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
; let (errs, names) = splitEithers mb_gres
; when (null names) $ addErr (head errs)
; return names }
where
lookup = lookupBindGroupOcc ctxt what
dataTcOccs :: RdrName -> [RdrName]
dataTcOccs rdr_name
| isDataOcc occ || isVarOcc occ
= [rdr_name, rdr_name_tc]
| otherwise
= [rdr_name]
where
occ = rdrNameOcc rdr_name
rdr_name_tc = setRdrNameSpace rdr_name tcName
type MiniFixityEnv = FastStringEnv (Located Fixity)
addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities mini_fix_env names thing_inside
= extendFixityEnv (mapMaybe find_fixity names) thing_inside
where
find_fixity name
= case lookupFsEnv mini_fix_env (occNameFS occ) of
Just (L _ fix) -> Just (name, FixItem occ fix)
Nothing -> Nothing
where
occ = nameOccName name
lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn name
| isUnboundName name
= return (Fixity minPrecedence InfixL)
| otherwise
= do { local_fix_env <- getFixityEnv
; case lookupNameEnv local_fix_env name of {
Just (FixItem _ fix) -> return fix ;
Nothing ->
do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod name
then return defaultFixity
else lookup_imported } } }
where
lookup_imported
= do { iface <- loadInterfaceForName doc name
; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)])
; return (mi_fix_fn iface (nameOccName name)) }
doc = ptext (sLit "Checking fixity for") <+> ppr name
lookupTyFixityRn :: Located Name -> RnM Fixity
lookupTyFixityRn (L _ n) = lookupFixityRn n
lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
lookupIfThenElse
= do { rebind <- xoptM Opt_RebindableSyntax
; if not rebind
then return (Nothing, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
; return (Just (HsVar ite), unitFV ite) } }
lookupSyntaxName :: Name
-> RnM (SyntaxExpr Name, FreeVars)
lookupSyntaxName std_name
= do { rebindable_on <- xoptM Opt_RebindableSyntax
; if not rebindable_on then
return (HsVar std_name, emptyFVs)
else
do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
; return (HsVar usr_name, unitFV usr_name) } }
lookupSyntaxNames :: [Name]
-> RnM ([HsExpr Name], FreeVars)
lookupSyntaxNames std_names
= do { rebindable_on <- xoptM Opt_RebindableSyntax
; if not rebindable_on then
return (map HsVar std_names, emptyFVs)
else
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
; return (map HsVar usr_names, mkFVs usr_names) } }
newLocalBndrRn :: Located RdrName -> RnM Name
newLocalBndrRn (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
= return name
| otherwise
= do { unless (isUnqual rdr_name)
(addErrAt loc (badQualBndrErr rdr_name))
; uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn = mapM newLocalBndrRn
bindLocatedLocalsRn :: [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
= do { checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
; bindLocalNames names (enclosed_scope names) }
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= do { lcl_env <- getLclEnv
; let th_level = thLevel (tcl_th_ctxt lcl_env)
th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
[ (n, (NotTopLevel, th_level)) | n <- names ]
rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
, tcl_rdr = rdr_env' })
enclosed_scope }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
= do { (result, fvs) <- bindLocalNames names enclosed_scope
; return (result, delFVs names fvs) }
bindLocatedLocalsFV :: [Located RdrName]
-> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
bindLocatedLocalsFV rdr_names enclosed_scope
= bindLocatedLocalsRn rdr_names $ \ names ->
do (thing, fvs) <- enclosed_scope names
return (thing, delFVs names fvs)
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
checkDupRdrNames :: [Located RdrName] -> RnM ()
checkDupRdrNames rdr_names_w_loc
= mapM_ (dupNamesErr getLoc) dups
where
(_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
checkDupNames :: [Name] -> RnM ()
checkDupNames names = check_dup_names (filterOut isSystemName names)
check_dup_names :: [Name] -> RnM ()
check_dup_names names
= mapM_ (dupNamesErr nameSrcSpan) dups
where
(_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
checkShadowedRdrNames :: [Located RdrName] -> RnM ()
checkShadowedRdrNames loc_rdr_names
= do { envs <- getRdrEnvs
; checkShadowedOccs envs get_loc_occ filtered_rdrs }
where
filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames envs names
= do { check_dup_names filtered_names
; checkShadowedOccs envs get_loc_occ filtered_names }
where
filtered_names = filterOut isSystemName names
get_loc_occ name = (nameSrcSpan name, nameOccName name)
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-> (a -> (SrcSpan, OccName))
-> [a] -> RnM ()
checkShadowedOccs (global_env,local_env) get_loc_occ ns
= whenWOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr (map get_loc_occ ns))
; mapM_ check_shadow ns }
where
check_shadow n
| startsWithUnderscore occ = return ()
| 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
(loc,occ) = get_loc_occ n
mb_local = lookupLocalRdrOcc local_env occ
gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env
complain [] = return ()
complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs)
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
is_shadowed_gre gre@(GRE { gre_par = ParentIs _ })
= do { dflags <- getDynFlags
; if (xopt Opt_RecordPuns dflags || xopt 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
| 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) }
data WhereLooking = WL_Any
| WL_Global
| WL_LocalTop
reportUnboundName :: RdrName -> RnM Name
reportUnboundName rdr = unboundName WL_Any rdr
unboundName :: WhereLooking -> RdrName -> RnM Name
unboundName wl rdr = unboundNameX wl rdr Outputable.empty
unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
unboundNameX where_look rdr_name extra
= do { show_helpful_errors <- goptM Opt_HelpfulErrors
; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
err = unknownNameErr what rdr_name $$ extra
; if not show_helpful_errors
then addErr err
else do { suggestions <- unknownNameSuggestErr where_look rdr_name
; addErr (err $$ suggestions) }
; return (mkUnboundName rdr_name) }
unknownNameErr :: SDoc -> RdrName -> SDoc
unknownNameErr what rdr_name
= vcat [ hang (ptext (sLit "Not in scope:"))
2 (what <+> quotes (ppr rdr_name))
, extra ]
where
extra | rdr_name == forall_tv_RDR = perhapsForallMsg
| otherwise = Outputable.empty
type HowInScope = Either SrcSpan ImpDeclSpec
unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc
unknownNameSuggestErr where_look tried_rdr_name
= do { local_env <- getLocalRdrEnv
; global_env <- getGlobalRdrEnv
; dflags <- getDynFlags
; let all_possibilities :: [(String, (RdrName, HowInScope))]
all_possibilities
= [ (showPpr dflags r, (r, Left loc))
| (r,loc) <- local_possibilities local_env ]
++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
perhaps = ptext (sLit "Perhaps you meant")
extra_err = case suggest of
[] -> Outputable.empty
[p] -> perhaps <+> pp_item p
ps -> sep [ perhaps <+> ptext (sLit "one of these:")
, nest 2 (pprWithCommas pp_item ps) ]
; return extra_err }
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc'
where loc' = case loc of
UnhelpfulSpan l -> parens (ppr l)
RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l))
pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
pp_ns :: RdrName -> SDoc
pp_ns rdr | ns /= tried_ns = pprNameSpace ns
| otherwise = Outputable.empty
where ns = rdrNameSpace rdr
tried_occ = rdrNameOcc tried_rdr_name
tried_is_sym = isSymOcc tried_occ
tried_ns = occNameSpace tried_occ
tried_is_qual = isQual tried_rdr_name
correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns
&& isSymOcc occ == tried_is_sym
local_ok = case where_look of { WL_Any -> True; _ -> False }
local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
local_possibilities env
| tried_is_qual = []
| not local_ok = []
| otherwise = [ (mkRdrUnqual occ, nameSrcSpan name)
| name <- localRdrEnvElts env
, let occ = nameOccName name
, correct_name_space occ]
gre_ok :: GlobalRdrElt -> Bool
gre_ok = case where_look of
WL_LocalTop -> isLocalGRE
_ -> \_ -> True
global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
global_possibilities global_env
| tried_is_qual = [ (rdr_qual, (rdr_qual, how))
| gre <- globalRdrEnvElts global_env
, gre_ok gre
, let name = gre_name gre
occ = nameOccName name
, correct_name_space occ
, (mod, how) <- quals_in_scope name (gre_prov gre)
, let rdr_qual = mkRdrQual mod occ ]
| otherwise = [ (rdr_unqual, pair)
| gre <- globalRdrEnvElts global_env
, gre_ok gre
, let name = gre_name gre
prov = gre_prov gre
occ = nameOccName name
rdr_unqual = mkRdrUnqual occ
, correct_name_space occ
, pair <- case (unquals_in_scope name prov, quals_only occ prov) of
(how:_, _) -> [ (rdr_unqual, how) ]
([], pr:_) -> [ pr ]
([], []) -> [] ]
unquals_in_scope :: Name -> Provenance -> [HowInScope]
unquals_in_scope n LocalDef = [ Left (nameSrcSpan n) ]
unquals_in_scope _ (Imported is) = [ Right ispec
| i <- is, let ispec = is_decl i
, not (is_qual ispec) ]
quals_in_scope :: Name -> Provenance -> [(ModuleName, HowInScope)]
quals_in_scope n LocalDef = case nameModule_maybe n of
Nothing -> []
Just m -> [(moduleName m, Left (nameSrcSpan n))]
quals_in_scope _ (Imported is) = [ (is_as ispec, Right ispec)
| i <- is, let ispec = is_decl i ]
quals_only :: OccName -> Provenance -> [(RdrName, HowInScope)]
quals_only _ LocalDef = []
quals_only occ (Imported is) = [ (mkRdrQual (is_as ispec) occ, Right ispec)
| i <- is, let ispec = is_decl i, is_qual ispec ]
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
; return (res, fvs1 `plusFV` fvs2) }
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn f xs = do stuff <- mapM f xs
case unzip stuff of
(ys, fvs_s) -> return (ys, plusFVs fvs_s)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
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')
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds gres
= whenWOptM Opt_WarnUnusedBinds
$ do env <- getGblEnv
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
ParentIs _ -> False
gres' = if isBoot then filter noParent gres
else gres
warnUnusedGREs gres'
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
warnUnusedMatches = check_unused Opt_WarnUnusedMatches
check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names
= whenWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs gres
= warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]
warnUnusedLocals :: [Name] -> RnM ()
warnUnusedLocals names
= warnUnusedBinds [(n,LocalDef) | n<-names]
warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names)
where reportable (name,_)
| isWiredInName name = False
| otherwise = not (startsWithUnderscore (nameOccName name))
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)]
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn rdr_name gres
| all isLocalGRE gres
= return ()
| otherwise
= addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
where
(np1:nps) = gres
msg1 = ptext (sLit "either") <+> mk_ref np1
msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps]
mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre]
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn 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)]
perhapsForallMsg :: SDoc
perhapsForallMsg
= vcat [ ptext (sLit "Perhaps you intended to use ExplicitForAll or similar flag")
, ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")]
unknownSubordinateErr :: SDoc -> RdrName -> SDoc
unknownSubordinateErr doc op
= 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)
dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
dupNamesErr get_loc names
= addErrAt big_loc $
vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)),
locations]
where
locs = map get_loc names
big_loc = foldr1 combineSrcSpans locs
locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sort locs))
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 KindSignatures"))
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 TypeOperators to declare operators in type and declarations"))
checkTupSize :: Int -> RnM ()
checkTupSize tup_size
| tup_size <= mAX_TUPLE_SIZE
= return ()
| otherwise
= addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)),
nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))])
data HsDocContext
= TypeSigCtx SDoc
| PatCtx
| SpecInstSigCtx
| DefaultDeclCtx
| ForeignDeclCtx (Located RdrName)
| DerivDeclCtx
| RuleCtx FastString
| TyDataCtx (Located RdrName)
| TySynCtx (Located RdrName)
| TyFamilyCtx (Located RdrName)
| ConDeclCtx [Located RdrName]
| ClassDeclCtx (Located RdrName)
| ExprWithTySigCtx
| TypBrCtx
| HsTypeCtx
| GHCiCtx
| SpliceTypeCtx (LHsType RdrName)
| ClassInstanceCtx
| VectDeclCtx (Located RdrName)
| GenericCtx SDoc
docOfHsDocContext :: HsDocContext -> SDoc
docOfHsDocContext (GenericCtx doc) = doc
docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
docOfHsDocContext PatCtx = text "In a pattern type-signature"
docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration"
docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name
docOfHsDocContext DerivDeclCtx = text "In a deriving declaration"
docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name
docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon)
docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name)
docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name)
docOfHsDocContext (ConDeclCtx [name])
= text "In the definition of data constructor" <+> quotes (ppr name)
docOfHsDocContext (ConDeclCtx names)
= text "In the definition of data constructors" <+> interpp'SP names
docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class" <+> ppr name
docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature"
docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type")
docOfHsDocContext HsTypeCtx = text "In a type argument"
docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)