-- so tcHsType will do the Right Thing without
-- having to mess about with zonking
-import TcEnv ( ValueEnv, tcExtendTyVarEnv,
- tcExtendGlobalValEnv, tcSetValueEnv,
- tcLookupValueMaybe,
- explicitLookupValue, valueEnvIds
+import TcEnv ( TcEnv, tcExtendTyVarEnv,
+ tcExtendGlobalValEnv, tcSetEnv,
+ tcLookupGlobal_maybe, explicitLookupId, tcEnvIds
)
import RnHsSyn ( RenamedHsDecl )
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkId, mkVanillaId,
- isDataConWrapId_maybe
- )
+import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
import MkId ( mkCCallOpId )
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
import ErrUtils ( pprBagOfErrors )
import Outputable
import Util ( zipWithEqual )
+import HscTypes ( TyThing(..) )
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
signatures.
\begin{code}
-tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings
+tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings
-> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
= listTc [ do_one name ty id_infos src_loc
| SigD (IfaceSig name ty id_infos src_loc) <- decls]
where
- in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+ in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env)
do_one name ty id_infos src_loc
= tcAddSrcLoc src_loc $
= uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on unf_env too eagerly!
- info' = case explicitLookupValue unf_env worker_name of
+ info' = case explicitLookupId unf_env worker_name of
Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
`setWorkerInfo` HasWorker worker_id arity
-- Check for type consistency in the unfolding
tcGetSrcLoc `thenNF_Tc` \ src_loc ->
- case lintUnfolding src_loc in_scope_vars core_expr' of
+ getDOptsTc `thenTc` \ dflags ->
+ case lintUnfolding dflags src_loc in_scope_vars core_expr' of
(Nothing,_) -> returnTc core_expr' -- ignore warnings
(Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
where
doc = text "unfolding of" <+> ppr name
-tcDelay :: ValueEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
+tcDelay :: TcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
tcDelay unf_env doc thing_inside
= forkNF_Tc (
recoverNF_Tc bad_value (
- tcSetValueEnv unf_env thing_inside `thenTc` \ r ->
+ tcSetEnv unf_env thing_inside `thenTc` \ r ->
returnTc (Just r)
))
where
\begin{code}
tcVar :: Name -> TcM Id
tcVar name
- = tcLookupGlobalMaybe name `thenNF_Tc` \ maybe_id ->
+ = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
case maybe_id of {
Just (AnId id) -> returnTc id;
Nothing -> failWithTc (noDecl name)
UfInlineCall -> returnTc (Note InlineCall expr')
UfInlineMe -> returnTc (Note InlineMe expr')
UfSCC cc -> returnTc (Note (SCC cc) expr')
-
-tcCoreNote (UfSCC cc) = returnTc (SCC cc)
-tcCoreNote UfInlineCall = returnTc InlineCall
\end{code}
\begin{code}