#include "HsVersions.h"
-import HsSyn ( HsDecl(..), IfaceSig(..), HsTupCon(..) )
+import HsSyn ( TyClDecl(..), HsTupCon(..) )
import TcMonad
import TcMonoType ( tcHsType )
-- NB: all the tyars in interface files are kinded,
-- so tcHsType will do the Right Thing without
-- having to mess about with zonking
-import TcEnv ( TcEnv, tcExtendTyVarEnv,
+import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetEnv,
- tcLookupGlobal_maybe, explicitLookupId, tcEnvIds
+ tcLookupGlobal_maybe, tcLookupRecId_maybe
)
-import RnHsSyn ( RenamedHsDecl )
+import RnHsSyn ( RenamedTyClDecl )
import HsCore
import Literal ( Literal(..) )
import CoreSyn
import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
import MkId ( mkCCallOpId )
import IdInfo
-import DataCon ( dataConSig, dataConArgTys )
-import Type ( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy )
+import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
+import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
+import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
-import Name ( Name, isLocallyDefined )
+import Name ( Name )
import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Outputable
signatures.
\begin{code}
-tcInterfaceSigs :: TcEnv -- Envt to use when checking unfoldings
- -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
+tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
+ -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
tcInterfaceSigs unf_env decls
= listTc [ do_one name ty id_infos src_loc
- | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+ | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
where
- in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env)
+ in_scope_vars = [] -- I think this will be OK
do_one name ty id_infos src_loc
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ifaceSigCtxt name) $
tcHsType ty `thenTc` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
- sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
+ sigma_ty id_infos `thenTc` \ id_info ->
returnTc (mkId name sigma_ty id_info)
\end{code}
\begin{code}
-tcIdInfo unf_env in_scope_vars name ty info info_ins
- = foldlTc tcPrag vanillaIdInfo info_ins
+tcIdInfo unf_env in_scope_vars name ty info_ins
+ = foldlTc tcPrag constantIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
= 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 explicitLookupId unf_env worker_name of
- Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
- `setWorkerInfo` HasWorker worker_id arity
+ info' = case tcLookupRecId_maybe unf_env worker_name of
+ Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
+ `setWorkerInfo` HasWorker worker_id arity
- Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
+ Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
in
returnTc info'
where
where
doc = text "unfolding of" <+> ppr name
-tcDelay :: TcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
+tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
tcDelay unf_env doc thing_inside
= forkNF_Tc (
recoverNF_Tc bad_value (
tcGetUnique `thenNF_Tc` \ u ->
returnTc (Var (mkCCallOpId u cc ty'))
-tcCoreExpr (UfTuple (HsTupCon name _) args)
- = tcVar name `thenTc` \ con_id ->
- mapTc tcCoreExpr args `thenTc` \ args' ->
+tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
+ = mapTc tcCoreExpr args `thenTc` \ args' ->
let
-- Put the missing type arguments back in
- con_args = map (Type . unUsgTy . exprType) args' ++ args'
+ con_args = map (Type . exprType) args' ++ args'
in
returnTc (mkApps (Var con_id) con_args)
+ where
+ con_id = dataConId (tupleCon boxity arity)
+
tcCoreExpr (UfLam bndr body)
= tcCoreLamBndr bndr $ \ bndr' ->
= tcCoreExpr expr `thenTc` \ expr' ->
case note of
UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
- returnTc (Note (Coerce (unUsgTy to_ty')
- (unUsgTy (exprType expr'))) expr')
+ returnTc (Note (Coerce to_ty'
+ (exprType expr')) expr')
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}
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
-tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
- = tcVar con_name `thenTc` \ con_id ->
+tcCoreAlt scrut_ty alt@(con, names, rhs)
+ = tcConAlt con `thenTc` \ con ->
let
- con = case isDataConWrapId_maybe con_id of
- Just con -> con
- Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
-
(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
(_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
arg_ids
#ifdef DEBUG
| length id_names /= length arg_tys
- = pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
+ = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
(ppr main_tyvars <+> ppr ex_tyvars) $$
ppr arg_tys)
| otherwise
tcExtendGlobalValEnv arg_ids $
tcCoreExpr rhs `thenTc` \ rhs' ->
returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+
+
+tcConAlt :: UfConAlt Name -> TcM DataCon
+tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
+ = returnTc (tupleCon boxity arity)
+
+tcConAlt (UfDataAlt con_name)
+ = tcVar con_name `thenTc` \ con_id ->
+ returnTc (case isDataConWrapId_maybe con_id of
+ Just con -> con
+ Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff