import PrelRules ( primOpRules )
import Rules ( addRule )
import Type ( TyThing(..) )
-import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
- mkTyVarTys, mkClassPred, tcEqPred,
+import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
+ mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
- tcSplitFunTys, tcSplitForAllTys, mkPredTy
+ tcSplitFunTys, tcSplitForAllTys
)
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
-- NB: this code relies on the fact that DataCons are quantified over
-- the identical type variables as their parent TyCon
needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConStupidTheta dc]
- dict_tys = map mkPredTy (nubBy tcEqPred needed_preds)
+ dict_tys = mkPredTys (nubBy tcEqPred needed_preds)
n_dict_tys = length dict_tys
(field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
- field_dict_tys = map mkPredTy field_theta
+ field_dict_tys = mkPredTys field_theta
n_field_dict_tys = length field_dict_tys
-- If the field has a universally quantified type we have to
-- be a bit careful. Suppose we have
-- foo = /\a. \t:T. case t of { MkT f -> f a }
mk_maybe_alt data_con
- = case maybe_the_arg_id of
+ = ASSERT( dc_tyvars == tyvars )
+ -- The only non-vanilla case we allow is when we have an existential
+ -- context that binds no type variables, thus
+ -- data T a = (?v::Int) => MkT a
+ -- In the non-vanilla case, the pattern must bind type variables and
+ -- the context stuff; hence the arg_prefix binding below
+
+ case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids $
+ Just the_arg_id -> Just (mkReboxingAlt uniqs data_con (arg_prefix ++ arg_src_ids) $
mk_result (Var the_arg_id))
where
- arg_ids = ASSERT( isVanillaDataCon data_con )
- mkTemplateLocalsNum arg_base (dataConOrigArgTys data_con)
- -- Records can't be existential, so no existential tyvars or dicts
- -- Vanilla data con => tycon's tyvars will do
+ (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
+ arg_src_ids = mkTemplateLocalsNum arg_base dc_arg_tys
+ arg_base' = arg_base + length arg_src_ids
+ arg_prefix | isVanillaDataCon data_con = []
+ | otherwise = tyvars ++ mkTemplateLocalsNum arg_base' (mkPredTys dc_theta)
- unpack_base = arg_base + length arg_ids
+ unpack_base = arg_base' + length dc_theta
uniqs = map mkBuiltinUnique [unpack_base..]
- maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
+ maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_src_ids) field_label
field_lbls = dataConFieldLabels data_con
error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
mkReboxingAlt
:: [Unique] -- Uniques for the new Ids
-> DataCon
- -> [Var] -- Source-level args
+ -> [Var] -- Source-level args, including existential dicts
-> CoreExpr -- RHS
-> CoreAlt
; let
is_vanilla = null ex_tvs && null (unLoc ex_ctxt)
-- Vanilla iff no ex_tvs and no context
+ -- Must check the context too because of
+ -- implicit params; e.g.
+ -- data T = (?x::Int) => MkT Int
tc_datacon is_infix field_lbls btys
= do { let { bangs = map getBangStrictness btys }
; case details of
PrefixCon btys -> tc_datacon False [] btys
InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
- RecCon fields -> do { checkTc is_vanilla (exRecConErr name)
+ RecCon fields -> do { checkTc (null ex_tvs) (exRecConErr name)
+ -- It's ok to have an implicit-parameter context
+ -- for the data constructor, provided it binds
+ -- no type variables
; let { (field_names, btys) = unzip fields }
; tc_datacon False field_names btys } }