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,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
- eqStringName, printName,
- bindIOName, returnIOName, failIOName, thenIOName
+ eqStringName, printName, integerTyConName,
+ bindIOName, returnIOName, failIOName, thenIOName,
+ rOOT_MAIN_Name
)
#ifdef GHCI
import DsMeta ( templateHaskellNames, qTyConName )
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(..) )
| Just name <- isExact_maybe rdr_name
= returnM name
+ | isOrig rdr_name
+ = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name )
+ -- When reading External Core we get Orig names as binders,
+ -- but they should agree with the module gotten from the monad
+ --
+ -- Except for the ":Main.main = ..." definition inserted into
+ -- the Main module
+ --
+ -- Because of this latter case, we take the module from 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).
+ newGlobalName (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) loc
+
| otherwise
= newGlobalName mod (rdrNameOcc rdr_name) loc
+ where
+ rdr_mod = rdrNameModule rdr_name
newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name
newGlobalName mod occ loc
Nothing -> -- No names from this module yet
ioToTcRn (findModule mod_name) `thenM` \ mb_loc ->
case mb_loc of
- Just (mod, _) -> new_name mod
- Nothing -> addErr (noModule mod_name) `thenM_`
- -- Things have really gone wrong at this point,
- -- so having the wrong package info in the
- -- Module is the least of our worries.
- new_name (mkHomeModule mod_name)
- where
- noModule mod_name = ptext SLIT("Can't find interface for module") <+> ppr mod_name
+ Right (mod, _) -> new_name mod
+ Left files ->
+ getDOpts `thenM` \ dflags ->
+ addErr (noIfaceErr dflags mod_name False files) `thenM_`
+ -- Things have really gone wrong at this point,
+ -- so having the wrong package info in the
+ -- Module is the least of our worries.
+ new_name (mkHomeModule mod_name)
newIPName rdr_name_ip
-- A separate function (importsFromLocalDecls) reports duplicate top level
-- decls, so here it's safe just to choose an arbitrary one.
- -- There should never be a qualified name in a binding position in Haskell,
- -- but there can be if we have read in an external-Core file.
- -- The Haskell parser checks for the illegal qualified name, so we
- -- don't need to do so here.
+-- There should never be a qualified name in a binding position in Haskell,
+-- but there can be if we have read in an external-Core file.
+-- The Haskell parser checks for the illegal qualified name in Haskell
+-- source files, so we don't need to do so here.
- = ASSERT( not (isOrig rdr_name) )
- -- Original names are used only for occurrences,
- -- not binding sites
-
- getModeRn `thenM` \ mode ->
+ = getModeRn `thenM` \ mode ->
case mode of
InterfaceMode mod ->
getSrcLocM `thenM` \ loc ->
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
dataTcOccs :: RdrName -> [RdrName]
-- If the input is a data constructor, return both it and a type
-- constructor. This is useful when we aren't sure which we are
--- looking at
+-- looking at.
+--
+-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName,
+-- and we don't have a systematic way to find the TyCon's Name from
+-- the DataCon's name. Sigh
dataTcOccs rdr_name
- | isDataOcc occ = [rdr_name, rdr_name_tc]
+ | isDataOcc occ = [rdr_name_tc, rdr_name]
| otherwise = [rdr_name]
where
occ = rdrNameOcc rdr_name
implicitStmtFVs source_fvs -- Compiling a statement
= stmt_fvs `plusFV` implicitModuleFVs source_fvs
where
- stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName]
+ stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName,
+ integerTyConName]
-- These are all needed implicitly when compiling a statement
-- See TcModule.tc_stmts
+ -- Reason for integerTyConName: consider this in GHCi
+ -- ghci> []
+ -- We get an ambigous constraint (Show a), which we now default just like
+ -- numeric types... but unless we have the instance decl for Integer we
+ -- won't find a valid default!
implicitModuleFVs source_fvs
= mkTemplateHaskellFVs source_fvs `plusFV`
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
= -- Qualified names in patterns are now rejected by the parser
-- but I'm not 100% certain that it finds all cases, so I've left
-- this check in for now. Should go eventually.
- mappM_ (qualNameErr doc_str) quals `thenM_`
+ -- Hmm. Sooner rather than later.. data type decls
+-- mappM_ (qualNameErr doc_str) quals `thenM_`
checkDupNames doc_str rdr_names_w_loc
where
quals = filter (isQual . fst) rdr_names_w_loc
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]
$$
descriptor)
+noIfaceErr dflags mod_name boot_file files
+ = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
+ $$ extra
+ where
+ extra
+ | verbosity dflags < 3 =
+ text "(use -v to see a list of the files searched for)"
+ | otherwise =
+ hang (ptext SLIT("locations searched:")) 4 (vcat (map text files))
+
warnDeprec :: GlobalRdrElt -> TcRn m ()
warnDeprec (GRE {gre_name = name, gre_deprec = Just txt})
= ifOptM Opt_WarnDeprecations $
projects / ghc-hetmet.git / blobdiff