module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
lookupLocalOccRn_maybe, lookupInfoOccRn,
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
reportUnboundName, unknownNameSuggestions,
addNameClashErrRn,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
lookupFixityRn, lookupFixityRn_help,
lookupFieldFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
lookupConstructorFields,
lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,
lookupIfThenElse,
lookupGreAvailRn,
getLookupOccRn,mkUnboundName, mkUnboundNameRdr, isUnboundName,
addUsedGRE, addUsedGREs, addUsedDataCons,
newLocalBndrRn, newLocalBndrsRn,
bindLocalNames, bindLocalNamesFV,
MiniFixityEnv,
addLocalFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
extendTyVarEnvFVRn,
RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,
lookupRoleAnnot, getRoleAnnots,
checkDupRdrNames, checkShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames, dupNamesErr,
checkTupSize,
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedTypePatterns,
warnUnusedTopBinds, warnUnusedLocalBinds,
mkFieldEnv,
dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
HsDocContext(..), pprHsDocContext,
inHsDocContext, withHsDocContext
) where
#include "HsVersions.h"
import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe )
import IfaceEnv
import HsSyn
import RdrName
import HscTypes
import TcEnv
import TcRnMonad
import RdrHsSyn ( setRdrNameSpace )
import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName )
import Name
import NameSet
import NameEnv
import Avail
import Module
import ConLike
import DataCon
import TyCon
import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
import ErrUtils ( MsgDoc )
import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence,
defaultFixity, pprWarningTxtForMsg, SourceText(..) )
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 Data.Function ( on )
import ListSetOps ( minusList )
import Constants ( mAX_TUPLE_SIZE )
import qualified GHC.LanguageExtensions as LangExt
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 { this_mod <- getModule
; externaliseName this_mod 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
; if isBrackStage stage then
do { uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
else
do { this_mod <- getModule
; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)
; 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 "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 LangExt.TypeOperators
; unless op_ok (addErr (opDeclErr rdr_name)) })
; env <- getGlobalRdrEnv
; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of
[gre] -> return (Just (gre_name gre))
_ -> return Nothing
}
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
[gre] -> return (Right (gre_name gre))
[] ->
do { lcl_env <- getLocalRdrEnv
; if name `inLocalRdrEnvScope` lcl_env
then return (Right name)
else
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)
}
}
gres -> return (Left (sameNameErr gres))
}
where
exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "
, text "perhaps via newName, but did not bind it"
, text "If that's it, then -ddump-splices might be useful" ])
sameNameErr :: [GlobalRdrElt] -> MsgDoc
sameNameErr [] = panic "addSameNameErr: empty list"
sameNameErr gres@(_ : _)
= hang (text "Same exact name in multiple name-spaces:")
2 (vcat (map pp_one sorted_names) $$ th_hint)
where
sorted_names = sortWith nameSrcLoc (map gre_name gres)
pp_one name
= hang (pprNameSpace (occNameSpace (getOccName name))
<+> quotes (ppr name) <> comma)
2 (text "declared at:" <+> ppr (nameSrcLoc name))
th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"
, text "perhaps via newName, in different name-spaces."
, text "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))
; mb_name <- lookupSubBndrOcc
False
cls doc rdr
; case mb_name of
Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }
Right nm -> return nm }
where
doc = what <+> text "of class" <+> quotes (ppr cls)
lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)
lookupFamInstName (Just cls) tc_rdr
= wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr
lookupFamInstName Nothing tc_rdr
= lookupLocatedOccRn tc_rdr
lookupConstructorFields :: Name -> RnM [FieldLabel]
lookupConstructorFields con_name
= do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod con_name then
do { field_env <- getRecFieldEnv
; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)
; return (lookupNameEnv field_env con_name `orElse` []) }
else
do { con <- tcLookupConLike con_name
; traceTc "lookupCF 2" (ppr con)
; return (conLikeFieldLabels con) } }
lookupRecFieldOcc :: Maybe Name
-> SDoc -> RdrName
-> RnM Name
lookupRecFieldOcc parent doc rdr_name
| Just tc_name <- parent
= do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name
; case mb_name of
Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
Right n -> return n }
| otherwise
= lookupGlobalOccRn rdr_name
lookupSubBndrOcc :: Bool
-> Name
-> SDoc
-> RdrName
-> RnM (Either MsgDoc Name)
lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name
| Just n <- isExact_maybe rdr_name
= do { n <- lookupExactOcc n
; return (Right n) }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { n <- lookupOrig rdr_mod rdr_occ
; return (Right n) }
| isUnboundName the_parent
= return (Right (mkUnboundNameRdr rdr_name))
| otherwise
= do { env <- getGlobalRdrEnv
; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; traceRn "lookupSubBndrOcc"
(vcat [ ppr the_parent, ppr rdr_name
, ppr gres, ppr (pick_gres rdr_name gres)])
; case pick_gres rdr_name gres of
(gre:_) -> do { addUsedGRE warn_if_deprec gre
; return (Right (gre_name gre)) }
[] -> do { ns <- lookupQualifiedNameGHCi rdr_name
; case ns of
(n:_) -> return (Right n)
[] -> return (Left (unknownSubordinateErr doc rdr_name))
} }
where
pick_gres rdr_name gres
| isUnqual rdr_name = filter right_parent gres
| otherwise = filter right_parent (pickGREs rdr_name gres)
right_parent (GRE { gre_par = p })
| ParentIs parent <- p = parent == the_parent
| FldParent { par_is = parent } <- p = parent == the_parent
| otherwise = False
getLookupOccRn :: RnM (Name -> Maybe Name)
getLookupOccRn
= do local_env <- getLocalRdrEnv
return (lookupLocalRdrOcc local_env . nameOccName)
mkUnboundNameRdr :: RdrName -> Name
mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
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
| isVarOcc (rdrNameOcc rdr_name)
= badVarInType rdr_name
| otherwise
= do { typeintype <- xoptM LangExt.TypeInType
; if | typeintype -> lookupTypeOccRn rdr_name
| is_star rdr_name -> return starKindTyConName
| is_uni_star rdr_name -> return unicodeStarKindTyConName
| otherwise -> lookupOccRn rdr_name }
lookupTypeOccRn :: RdrName -> RnM Name
lookupTypeOccRn rdr_name
| isVarOcc (rdrNameOcc rdr_name)
= badVarInType rdr_name
| otherwise
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of {
Just name -> return name ;
Nothing -> do { dflags <- getDynFlags
; lookup_demoted rdr_name dflags } } }
lookup_demoted :: RdrName -> DynFlags -> RnM Name
lookup_demoted rdr_name dflags
| Just demoted_rdr <- demoteRdrName rdr_name
= do { data_kinds <- xoptM LangExt.DataKinds
; mb_demoted_name <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_name of
Nothing -> unboundNameX WL_Any rdr_name star_info
Just demoted_name
| data_kinds ->
do { whenWOptM Opt_WarnUntickedPromotedConstructors $
addWarn (Reason Opt_WarnUntickedPromotedConstructors)
(untickedPromConstrWarn demoted_name)
; return demoted_name }
| otherwise -> unboundNameX WL_Any rdr_name suggest_dk }
| otherwise
= reportUnboundName rdr_name
where
suggest_dk = text "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 ]
star_info
| is_star rdr_name || is_uni_star rdr_name
= if xopt LangExt.TypeInType dflags
then text "NB: With TypeInType, you must import" <+>
ppr rdr_name <+> text "from Data.Kind"
else empty
| otherwise
= empty
is_star, is_uni_star :: RdrName -> Bool
is_star = (fsLit "*" ==) . occNameFS . rdrNameOcc
is_uni_star = (fsLit "★" ==) . occNameFS . rdrNameOcc
badVarInType :: RdrName -> RnM Name
badVarInType rdr_name
= do { addErr (text "Illegal promoted term variable in a type:"
<+> ppr rdr_name)
; return (mkUnboundNameRdr rdr_name) }
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
; lookupGlobalOccRn_maybe rdr_name } }
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 {
Just gre -> return (Just (gre_name gre)) ;
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 "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)) }
lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
lookupOccRn_overloaded overload_ok rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
Just name -> return (Just (Left name)) ;
Nothing -> do
{ mb_name <- lookupGlobalOccRn_overloaded overload_ok rdr_name
; case mb_name of {
Just name -> return (Just name) ;
Nothing -> do
{ ns <- lookupQualifiedNameGHCi rdr_name
; case ns of
(n:_) -> return $ Just $ Left n
[] -> return Nothing } } } } }
lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
lookupGlobalOccRn_overloaded overload_ok rdr_name
| Just n <- isExact_maybe rdr_name
= do { n' <- lookupExactOcc n; return (Just (Left n')) }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { n <- lookupOrig rdr_mod rdr_occ
; return (Just (Left n)) }
| otherwise
= do { env <- getGlobalRdrEnv
; case lookupGRE_RdrName rdr_name env of
[] -> return Nothing
[gre] | isRecFldGRE gre
-> do { addUsedGRE True gre
; let
fld_occ :: FieldOcc Name
fld_occ
= FieldOcc (noLoc rdr_name) (gre_name gre)
; return (Just (Right [fld_occ])) }
| otherwise
-> do { addUsedGRE True gre
; return (Just (Left (gre_name gre))) }
gres | all isRecFldGRE gres && overload_ok
-> return
(Just (Right
(map (FieldOcc (noLoc rdr_name) . gre_name)
gres)))
gres -> do { addNameClashErrRn rdr_name gres
; return (Just (Left (gre_name (head gres)))) } }
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreRn_maybe rdr_name
= do { env <- getGlobalRdrEnv
; case lookupGRE_RdrName rdr_name env of
[] -> return Nothing
[gre] -> do { addUsedGRE True gre
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; traceRn "lookupGreRn:name clash"
(ppr rdr_name $$ ppr gres $$ ppr env)
; return (Just (head gres)) } }
lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreRn2_maybe rdr_name
= do { env <- getGlobalRdrEnv
; case lookupGRE_RdrName rdr_name env of
[] -> do { _ <- unboundName WL_Global rdr_name
; return Nothing }
[gre] -> do { addUsedGRE True gre
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; traceRn "lookupGreRn_maybe:name clash"
(ppr rdr_name $$ ppr gres $$ ppr env)
; return Nothing } }
lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
lookupGreAvailRn rdr_name
= do { mb_gre <- lookupGreRn2_maybe rdr_name
; case mb_gre of {
Just gre -> return (gre_name gre, availFromGRE gre) ;
Nothing ->
do { traceRn "lookupGreAvailRn" (ppr rdr_name)
; let name = mkUnboundNameRdr rdr_name
; return (name, avail name) } } }
addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
addUsedDataCons rdr_env tycon
= addUsedGREs [ gre
| dc <- tyConDataCons tycon
, Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()
addUsedGRE warn_if_deprec gre
= do { when warn_if_deprec (warnIfDeprecated gre)
; unless (isLocalGRE gre) $
do { env <- getGblEnv
; traceRn "addUsedGRE" (ppr gre)
; updMutVar (tcg_used_gres env) (gre :) } }
addUsedGREs :: [GlobalRdrElt] -> RnM ()
addUsedGREs gres
| null imp_gres = return ()
| otherwise = do { env <- getGblEnv
; traceRn "addUsedGREs" (ppr imp_gres)
; updMutVar (tcg_used_gres env) (imp_gres ++) }
where
imp_gres = filterOut isLocalGRE gres
warnIfDeprecated :: GlobalRdrElt -> RnM ()
warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
| (imp_spec : _) <- iss
= do { dflags <- getDynFlags
; this_mod <- getModule
; when (wopt Opt_WarnWarningsDeprecations dflags &&
not (nameIsLocalOrFrom this_mod name)) $
do { iface <- loadInterfaceForName doc name
; case lookupImpDeprec iface gre of
Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
(mk_msg imp_spec txt)
Nothing -> return () } }
| otherwise
= return ()
where
occ = greOccName gre
name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
mk_msg imp_spec txt
= sep [ sep [ text "In the use of"
<+> pprNonVarNameSpace (occNameSpace occ)
<+> quotes (ppr occ)
, parens imp_msg <> colon ]
, pprWarningTxtForMsg txt ]
where
imp_mod = importSpecModule imp_spec
imp_msg = text "imported from" <+> ppr imp_mod <> extra
extra | imp_mod == moduleName name_mod = Outputable.empty
| otherwise = text ", but defined in" <+> ppr name_mod
lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
lookupImpDeprec iface gre
= mi_warn_fn iface (greOccName gre) `mplus`
case gre_par gre of
ParentIs p -> mi_warn_fn iface (nameOccName p)
FldParent { par_is = p } -> mi_warn_fn iface (nameOccName 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 iface
-> return [ name
| avail <- mi_exports iface
, name <- availNames avail
, nameOccName name == occ ]
_ ->
do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)
; return [] } }
| otherwise
= do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)
; return [] }
doc = text "Need to find" <+> ppr rdr_name
data HsSigCtxt
= TopSigCtxt NameSet
| LocalBindCtxt NameSet
| ClsDeclCtxt Name
| InstDeclCtxt NameSet
| HsBootCtxt NameSet
| RoleAnnotCtxt NameSet
instance Outputable HsSigCtxt where
ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns
ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns
ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n
ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns
ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns
ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns
lookupSigOccRn :: HsSigCtxt
-> Sig RdrName
-> Located RdrName -> RnM (Located Name)
lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
lookupSigCtxtOccRn :: HsSigCtxt
-> SDoc
-> Located RdrName -> RnM (Located Name)
lookupSigCtxtOccRn ctxt what
= wrapLocM $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
; case mb_name of
Left err -> do { addErr err; return (mkUnboundNameRdr 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 ns -> lookup_top (`elemNameSet` ns)
TopSigCtxt ns -> lookup_top (`elemNameSet` ns)
RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls
InstDeclCtxt ns -> lookup_top (`elemNameSet` ns)
where
lookup_cls_op cls
= lookupSubBndrOcc True cls doc rdr_name
where
doc = text "method of class" <+> quotes (ppr cls)
lookup_top keep_me
= 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:_) -> 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 [ text "The" <+> what
<+> text "for" <+> quotes (ppr rdr_name)
, nest 2 $ text "lacks an accompanying binding"]
$$ nest 2 msg))
local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where")
<+> quotes (ppr rdr_name) <+> text "is declared"
lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, 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 rdr = do { name <- lookupBindGroupOcc ctxt what rdr
; return (fmap ((,) rdr) name) }
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 = lookupFixityRn' name (nameOccName name)
lookupFixityRn' :: Name -> OccName -> RnM Fixity
lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
lookupFixityRn_help :: Name
-> RnM (Bool, Fixity)
lookupFixityRn_help name =
lookupFixityRn_help' name (nameOccName name)
lookupFixityRn_help' :: Name
-> OccName
-> RnM (Bool, Fixity)
lookupFixityRn_help' name occ
| isUnboundName name
= return (False, Fixity NoSourceText minPrecedence InfixL)
| otherwise
= do { local_fix_env <- getFixityEnv
; case lookupNameEnv local_fix_env name of {
Just (FixItem _ fix) -> return (True, fix) ;
Nothing ->
do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod name
then return (False, defaultFixity)
else lookup_imported } } }
where
lookup_imported
= do { iface <- loadInterfaceForName doc name
; let mb_fix = mi_fix_fn iface occ
; let msg = case mb_fix of
Nothing ->
text "looking up name" <+> ppr name
<+> text "in iface, but found no fixity for it."
<+> text "Using default fixity instead."
Just f ->
text "looking up name in iface and found:"
<+> vcat [ppr name, ppr f]
; traceRn "lookupFixityRn_either:" msg
; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) }
doc = text "Checking fixity for" <+> ppr name
lookupTyFixityRn :: Located Name -> RnM Fixity
lookupTyFixityRn (L _ n) = lookupFixityRn n
lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
lookupFieldFixityRn (Unambiguous (L _ rdr) n)
= lookupFixityRn' n (rdrNameOcc rdr)
lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
where
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity rdr_name = do
traceRn "get_ambiguous_fixity" (ppr rdr_name)
rdr_env <- getGlobalRdrEnv
let elts = lookupGRE_RdrName rdr_name rdr_env
fixities <- groupBy ((==) `on` snd) . zip elts
<$> mapM lookup_gre_fixity elts
case fixities of
[] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
[ (_, fix):_ ] -> return fix
ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
>> return (Fixity NoSourceText minPrecedence InfixL)
lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
ambiguous_fixity_err rn ambigs
= vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
, hang (text "Conflicts: ") 2 . vcat .
map format_ambig $ concat ambigs ]
format_ambig (elt, fix) = hang (ppr fix)
2 (pprNameProvenance elt)
type RoleAnnotEnv = NameEnv (LRoleAnnotDecl Name)
mkRoleAnnotEnv :: [LRoleAnnotDecl Name] -> RoleAnnotEnv
mkRoleAnnotEnv role_annot_decls
= mkNameEnv [ (name, ra_decl)
| ra_decl <- role_annot_decls
, let name = roleAnnotDeclName (unLoc ra_decl)
, not (isUnboundName name) ]
emptyRoleAnnotEnv :: RoleAnnotEnv
emptyRoleAnnotEnv = emptyNameEnv
lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl Name)
lookupRoleAnnot = lookupNameEnv
getRoleAnnots :: [Name] -> RoleAnnotEnv -> ([LRoleAnnotDecl Name], RoleAnnotEnv)
getRoleAnnots bndrs role_env
= ( mapMaybe (lookupRoleAnnot role_env) bndrs
, delListFromNameEnv role_env bndrs )
lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
lookupIfThenElse
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on
then return (Nothing, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
; return ( Just (mkRnSyntaxExpr ite)
, unitFV ite ) } }
lookupSyntaxName' :: Name
-> RnM Name
lookupSyntaxName' std_name
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
return std_name
else
lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
lookupSyntaxName :: Name
-> RnM (SyntaxExpr Name, FreeVars)
lookupSyntaxName std_name
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
return (mkRnSyntaxExpr std_name, emptyFVs)
else
do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }
lookupSyntaxNames :: [Name]
-> RnM ([HsExpr Name], FreeVars)
lookupSyntaxNames std_names
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
return (map (HsVar . noLoc) std_names, emptyFVs)
else
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
; return (map (HsVar . noLoc) 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 "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
; mapM_ check_shadow ns }
where
check_shadow n
| startsWithUnderscore occ = return ()
| Just n <- mb_local = complain [text "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 (Reason Opt_WarnNameShadowing)
loc
(shadowedNameWarn occ pp_locs)
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
is_shadowed_gre gre | isRecFldGRE gre
= do { dflags <- getDynFlags
; return $ not (xopt LangExt.RecordPuns dflags
|| xopt LangExt.RecordWildCards dflags) }
is_shadowed_gre _other = return True
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 { dflags <- getDynFlags
; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
err = unknownNameErr what rdr_name $$ extra
; if not show_helpful_errors
then addErr err
else do { local_env <- getLocalRdrEnv
; global_env <- getGlobalRdrEnv
; impInfo <- getImports
; let suggestions = unknownNameSuggestions_ where_look
dflags global_env local_env impInfo rdr_name
; addErr (err $$ suggestions) }
; return (mkUnboundNameRdr rdr_name) }
unknownNameErr :: SDoc -> RdrName -> SDoc
unknownNameErr what rdr_name
= vcat [ hang (text "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
unknownNameSuggestions :: DynFlags
-> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
-> RdrName -> SDoc
unknownNameSuggestions = unknownNameSuggestions_ WL_Any
unknownNameSuggestions_ :: WhereLooking -> DynFlags
-> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
-> RdrName -> SDoc
unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name =
similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
importSuggestions dflags imports tried_rdr_name
similarNameSuggestions :: WhereLooking -> DynFlags
-> GlobalRdrEnv -> LocalRdrEnv
-> RdrName -> SDoc
similarNameSuggestions where_look dflags global_env
local_env tried_rdr_name
= case suggest of
[] -> Outputable.empty
[p] -> perhaps <+> pp_item p
ps -> sep [ perhaps <+> text "one of these:"
, nest 2 (pprWithCommas pp_item ps) ]
where
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 = text "Perhaps you meant"
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 (text "line" <+> int (srcSpanStartLine l))
pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>
parens (text "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 gre
, let rdr_qual = mkRdrQual mod occ ]
| otherwise = [ (rdr_unqual, pair)
| gre <- globalRdrEnvElts global_env
, gre_ok gre
, let name = gre_name gre
occ = nameOccName name
rdr_unqual = mkRdrUnqual occ
, correct_name_space occ
, pair <- case (unquals_in_scope gre, quals_only gre) of
(how:_, _) -> [ (rdr_unqual, how) ]
([], pr:_) -> [ pr ]
([], []) -> [] ]
unquals_in_scope :: GlobalRdrElt -> [HowInScope]
unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
| lcl = [ Left (nameSrcSpan n) ]
| otherwise = [ Right ispec
| i <- is, let ispec = is_decl i
, not (is_qual ispec) ]
quals_in_scope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
quals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
| lcl = case nameModule_maybe n of
Nothing -> []
Just m -> [(moduleName m, Left (nameSrcSpan n))]
| otherwise = [ (is_as ispec, Right ispec)
| i <- is, let ispec = is_decl i ]
quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]
quals_only (GRE { gre_name = n, gre_imp = is })
= [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)
| i <- is, let ispec = is_decl i, is_qual ispec ]
importSuggestions :: DynFlags -> ImportAvails -> RdrName -> SDoc
importSuggestions _dflags imports rdr_name
| not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty
| null interesting_imports
, Just name <- mod_name
= hsep
[ text "No module named"
, quotes (ppr name)
, text "is imported."
]
| is_qualified
, null helpful_imports
, [(mod,_)] <- interesting_imports
= hsep
[ text "Module"
, quotes (ppr mod)
, text "does not export"
, quotes (ppr occ_name) <> dot
]
| is_qualified
, null helpful_imports
, mods <- map fst interesting_imports
= hsep
[ text "Neither"
, quotedListWithNor (map ppr mods)
, text "exports"
, quotes (ppr occ_name) <> dot
]
| [(mod,imv)] <- helpful_imports_non_hiding
= fsep
[ text "Perhaps you want to add"
, quotes (ppr occ_name)
, text "to the import list"
, text "in the import of"
, quotes (ppr mod)
, parens (ppr (imv_span imv)) <> dot
]
| not (null helpful_imports_non_hiding)
= fsep
[ text "Perhaps you want to add"
, quotes (ppr occ_name)
, text "to one of these import lists:"
]
$$
nest 2 (vcat
[ quotes (ppr mod) <+> parens (ppr (imv_span imv))
| (mod,imv) <- helpful_imports_non_hiding
])
| [(mod,imv)] <- helpful_imports_hiding
= fsep
[ text "Perhaps you want to remove"
, quotes (ppr occ_name)
, text "from the explicit hiding list"
, text "in the import of"
, quotes (ppr mod)
, parens (ppr (imv_span imv)) <> dot
]
| not (null helpful_imports_hiding)
= fsep
[ text "Perhaps you want to remove"
, quotes (ppr occ_name)
, text "from the hiding clauses"
, text "in one of these imports:"
]
$$
nest 2 (vcat
[ quotes (ppr mod) <+> parens (ppr (imv_span imv))
| (mod,imv) <- helpful_imports_hiding
])
| otherwise
= Outputable.empty
where
is_qualified = isQual rdr_name
(mod_name, occ_name) = case rdr_name of
Unqual occ_name -> (Nothing, occ_name)
Qual mod_name occ_name -> (Just mod_name, occ_name)
_ -> error "importSuggestions: dead code"
interesting_imports = [ (mod, imp)
| (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
, Just imp <- return $ pick (importedByUser mod_imports)
]
pick :: [ImportedModsVal] -> Maybe ImportedModsVal
pick = listToMaybe . sortBy (compare `on` prefer) . filter select
where select imv = case mod_name of Just name -> imv_name imv == name
Nothing -> not (imv_qualified imv)
prefer imv = (imv_is_hiding imv, imv_span imv)
helpful_imports = filter helpful interesting_imports
where helpful (_,imv)
= not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name
(helpful_imports_hiding, helpful_imports_non_hiding)
= partition (imv_is_hiding . snd) helpful_imports
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_WarnUnusedTopBinds
$ do env <- getGblEnv
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
_ -> False
gres' = if isBoot then filter noParent gres
else gres
warnUnusedGREs gres'
warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
:: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds
warnUnusedMatches = check_unused Opt_WarnUnusedMatches
warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names
= whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
bound_names))
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs gres = mapM_ warnUnusedGRE gres
warnUnused :: WarningFlag -> [Name] -> RnM ()
warnUnused flag names = do
fld_env <- mkFieldEnv <$> getGlobalRdrEnv
mapM_ (warnUnused1 flag fld_env) names
warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
warnUnused1 flag fld_env name
= when (reportable name occ) $
addUnusedWarning flag
occ (nameSrcSpan name)
(text "Defined but not used")
where
occ = case lookupNameEnv fld_env name of
Just (fl, _) -> mkVarOccFS fl
Nothing -> nameOccName name
warnUnusedGRE :: GlobalRdrElt -> RnM ()
warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
| lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
warnUnused1 Opt_WarnUnusedTopBinds fld_env name
| otherwise = when (reportable name occ) (mapM_ warn is)
where
occ = greOccName gre
warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
| gres <- occEnvElts rdr_env
, gre <- gres
, Just lbl <- [greLabel gre]
]
reportable :: Name -> OccName -> Bool
reportable name occ
| isWiredInName name = False
| otherwise = not (startsWithUnderscore occ)
addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning flag occ span msg
= addWarnAt (Reason flag) span $
sep [msg <> colon,
nest 2 $ pprNonVarNameSpace (occNameSpace occ)
<+> quotes (ppr occ)]
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn rdr_name gres
| all isLocalGRE gres && not (all isRecFldGRE gres)
= return ()
| otherwise
= addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),
text "It could refer to" <+> vcat (msg1 : msgs)])
where
(np1:nps) = gres
msg1 = ptext (sLit "either") <+> mk_ref np1
msgs = [text " or" <+> mk_ref np | np <- nps]
mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
where nom = case gre_par gre of
FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
_ -> quotes (ppr (gre_name gre))
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn occ shadowed_locs
= sep [text "This binding for" <+> quotes (ppr occ)
<+> text "shadows the existing binding" <> plural shadowed_locs,
nest 2 (vcat shadowed_locs)]
perhapsForallMsg :: SDoc
perhapsForallMsg
= vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag"
, text "to enable explicit-forall syntax: forall <tvs>. <type>"]
unknownSubordinateErr :: SDoc -> RdrName -> SDoc
unknownSubordinateErr doc op
= quotes (ppr op) <+> text "is not a (visible)" <+> doc
badOrigBinding :: RdrName -> SDoc
badOrigBinding name
= text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)
dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
dupNamesErr get_loc names
= addErrAt big_loc $
vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
locations]
where
locs = map get_loc names
big_loc = foldr1 combineSrcSpans locs
locations = text "Bound at:" <+> vcat (map ppr (sort locs))
kindSigErr :: Outputable a => a -> SDoc
kindSigErr thing
= hang (text "Illegal kind signature for" <+> quotes (ppr thing))
2 (text "Perhaps you intended to use KindSignatures")
badQualBndrErr :: RdrName -> SDoc
badQualBndrErr rdr_name
= text "Qualified name in binding position:" <+> ppr rdr_name
opDeclErr :: RdrName -> SDoc
opDeclErr n
= hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
2 (text "Use TypeOperators to declare operators in type and declarations")
checkTupSize :: Int -> RnM ()
checkTupSize tup_size
| tup_size <= mAX_TUPLE_SIZE
= return ()
| otherwise
= addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
nest 2 (text "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)
| FamPatCtx (Located RdrName)
| ConDeclCtx [Located Name]
| ClassDeclCtx (Located RdrName)
| ExprWithTySigCtx
| TypBrCtx
| HsTypeCtx
| GHCiCtx
| SpliceTypeCtx (LHsType RdrName)
| ClassInstanceCtx
| VectDeclCtx (Located RdrName)
| GenericCtx SDoc
withHsDocContext :: HsDocContext -> SDoc -> SDoc
withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
inHsDocContext :: HsDocContext -> SDoc
inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
pprHsDocContext :: HsDocContext -> SDoc
pprHsDocContext (GenericCtx doc) = doc
pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc
pprHsDocContext PatCtx = text "a pattern type-signature"
pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
pprHsDocContext DerivDeclCtx = text "a deriving declaration"
pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name
pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)
pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)
pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name)
pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name)
pprHsDocContext ExprWithTySigCtx = text "an expression type signature"
pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type"
pprHsDocContext HsTypeCtx = text "a type argument"
pprHsDocContext GHCiCtx = text "GHCi input"
pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances"
pprHsDocContext (ForeignDeclCtx name)
= text "the foreign declaration for" <+> quotes (ppr name)
pprHsDocContext (ConDeclCtx [name])
= text "the definition of data constructor" <+> quotes (ppr name)
pprHsDocContext (ConDeclCtx names)
= text "the definition of data constructors" <+> interpp'SP names
pprHsDocContext (VectDeclCtx tycon)
= text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)