lookupFixity
)
import TcRnMonad
-import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName,
- mkInternalName, mkExternalName, mkIPName, nameSrcLoc,
- nameOccName, setNameSrcLoc, nameModule )
+import Name ( Name, getName, nameIsLocalOrFrom,
+ isWiredInName, mkInternalName, mkExternalName, mkIPName,
+ nameSrcLoc, nameOccName, setNameSrcLoc, nameModule )
import NameSet
-import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour )
+import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused )
import Module ( Module, ModuleName, moduleName, mkHomeModule,
lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
import PrelNames ( mkUnboundName, intTyConName,
import Finder ( findModule )
import FiniteMap
import UniqSupply
-import SrcLoc ( SrcLoc, noSrcLoc, importedSrcLoc )
+import SrcLoc ( SrcLoc, importedSrcLoc )
import Outputable
import ListSetOps ( removeDups, equivClasses )
import BasicTypes ( mapIPName, FixitySig(..) )
getGblEnv `thenM` \ gbl_env ->
let
avail_env = imp_env (tcg_imports gbl_env)
+ occ = rdrNameOcc rdr_name
in
- case lookupAvailEnv avail_env cls_name of
+ case lookupAvailEnv_maybe avail_env cls_name of
Nothing ->
-- If the class itself isn't in scope, then cls_name will
-- be unboundName, and there'll already be an error for
-- NB: qualified names are rejected by the parser
lookupOrigName rdr_name
- where
- occ = rdrNameOcc rdr_name
lookupSysBndr :: RdrName -> RnM Name
-- Used for the 'system binders' in a data type or class declaration
lookupSyntaxName :: Name -- The standard name
-> RnM (Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = getModeRn `thenM` \ mode ->
- if isInterfaceMode mode then
- returnM (std_name, unitFV std_name)
- -- Happens for 'derived' code
- -- where we don't want to rebind
+ = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
+ if not no_prelude then normal_case
else
-
- doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
- if not no_prelude then
- returnM (std_name, unitFV std_name) -- Normal case
-
+ getModeRn `thenM` \ mode ->
+ if isInterfaceMode mode then normal_case
+ -- Happens for 'derived' code where we don't want to rebind
else
-- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
returnM (usr_name, mkFVs [usr_name, std_name])
+ where
+ normal_case = returnM (std_name, unitFV std_name)
+
+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
+ else
+ getModeRn `thenM` \ mode ->
+ if isInterfaceMode mode then normal_case
+ else
+ -- Get the similarly named thing from the local environment
+ mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
+
+ returnM (std_names `zip` map HsVar usr_names, mkFVs std_names `plusFV` mkFVs usr_names)
+ where
+ normal_case = returnM (std_names `zip` map HsVar std_names, mkFVs std_names)
\end{code}
-- binLocalsFVRn is the same as bindLocalsRn
-- except that it deals with free vars
-bindLocalsFVRn doc rdr_names enclosed_scope
+bindLocalsFV doc rdr_names enclosed_scope
= bindLocalsRn doc rdr_names $ \ names ->
enclosed_scope names `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names)
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope (zipWith replaceTyVarName tyvar_names names)
-bindPatSigTyVars :: [RdrNameHsType]
- -> RnM (a, FreeVars)
- -> RnM (a, FreeVars)
+bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
-bindPatSigTyVars tys enclosed_scope
+bindPatSigTyVars tys thing_inside
= getLocalRdrEnv `thenM` \ name_env ->
getSrcLocM `thenM` \ loc ->
let
located_tyvars = [(tv, loc) | tv <- forall_tyvars]
doc_sig = text "In a pattern type-signature"
in
- bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
- enclosed_scope `thenM` \ (thing, fvs) ->
- returnM (thing, delListFromNameSet fvs names)
+ bindLocatedLocalsRn doc_sig located_tyvars thing_inside
+bindPatSigTyVarsFV :: [RdrNameHsType]
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
+bindPatSigTyVarsFV tys thing_inside
+ = bindPatSigTyVars tys $ \ tvs ->
+ thing_inside `thenM` \ (result,fvs) ->
+ returnM (result, fvs `delListFromNameSet` tvs)
-------------------------------------
checkDupOrQualNames, checkDupNames :: SDoc
where
occ = nameOccName name
elt = GRE {gre_name = name,
- gre_parent = parent,
+ gre_parent = if name == parent
+ then Nothing
+ else Just parent,
gre_prov = mk_provenance name,
gre_deprec = lookupDeprec deprecs name}
-
\end{code}
\begin{code}
warnUnusedBinds :: [(Name,Provenance)] -> TcRn m ()
warnUnusedBinds names
- = mappM_ warnUnusedGroup groups
+ = mappM_ warnUnusedGroup groups
where
-- Group by provenance
- groups = equivClasses cmp names
+ groups = equivClasses cmp (filter reportable names)
(_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
+ reportable (name,_) = reportIfUnused (nameOccName name)
+
-------------------------
warnUnusedGroup :: [(Name,Provenance)] -> TcRn m ()
warnUnusedGroup names
- | null filtered_names = returnM ()
- | not is_local = returnM ()
- | otherwise
= addSrcLoc def_loc $
- addWarn $
- sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
+ addWarn $
+ sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))]
where
- filtered_names = filter reportable names
- (name1, prov1) = head filtered_names
- (is_local, def_loc, msg)
- = case prov1 of
- LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
-
- NonLocalDef (UserImport mod loc _)
- -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
-
- reportable (name,_) = case occNameUserString (nameOccName name) of
- ('_' : _) -> False
- zz_other -> True
- -- Haskell 98 encourages compilers to suppress warnings about
- -- unused names in a pattern if they start with "_".
+ (name1, prov1) = head names
+ loc1 = nameSrcLoc name1
+ (def_loc, msg) = case prov1 of
+ LocalDef -> (loc1, unused_msg)
+ NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod)
+
+ unused_msg = text "Defined but not used"
+ imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used"
\end{code}
\begin{code}
addNameClashErrRn rdr_name (np1:nps)
= addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
- ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
+ ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
where
msg1 = ptext SLIT("either") <+> mk_ref np1
msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
projects / ghc-hetmet.git / blobdiff