import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType,
PredType(..),
mkTopTvSubst, substTyVar )
+import TcGadt ( gadtRefine, refineType, emptyRefinement )
+import HsBinds ( ExprCoFn(..), isIdCoercion )
import Coercion ( mkSymCoercion, mkUnsafeCoercion,
splitNewTypeRepCo_maybe, isEqPred )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, dataConInstPat )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
newTyConCo, tyConArity )
import Class ( Class, classTyCon, classSelIds )
-import Var ( Id, TyVar, Var, setIdType, mkWildCoVar )
+import Var ( Id, TyVar, Var, setIdType, mkCoVar, mkWildCoVar )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
-import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
+import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..),
+ mkSysTvName )
import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
n_stupid_dicts = length stupid_dict_tys
- (pre_field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty
- -- tcSplitSigmaTy puts tyvars with EqPred kinds in with the theta, but
- -- this is not what we want here, so we need to split out the EqPreds
- -- as new wild tyvars
- field_tyvars = pre_field_tyvars ++ eq_vars
- eq_vars = map (mkWildCoVar . mkPredTy)
- (filter isEqPred pre_field_theta)
+ (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty
+
field_theta = filter (not . isEqPred) pre_field_theta
field_dict_tys = mkPredTys field_theta
n_field_dict_tys = length field_dict_tys
mk_alt data_con
= -- In the non-vanilla case, the pattern must bind type variables and
-- the context stuff; hence the arg_prefix binding below
- mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id)
+ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) rhs
where
(arg_prefix, arg_ids)
| isVanillaDataCon data_con -- Instantiate from commmon base
= ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
| otherwise -- The case pattern binds type variables, which are used
-- in the types of the arguments of the pattern
- = (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
- mkTemplateLocalsNum arg_base' dc_arg_tys)
-
- (pre_dc_tvs, pre_dc_theta, dc_arg_tys) = dataConSig data_con
- -- again we need to pull the EqPreds out of dc_theta, into dc_tvs
- dc_eqvars = map (mkWildCoVar . mkPredTy . fixEqPred) (filter isEqPred pre_dc_theta)
- -- The type of the record selector Id does not contain the univ tvs
- -- but rather their substitution according to the eq_spec. Therefore
- -- the coercion arguments bound in the case alternative will just
- -- have reflexive coercion kinds
- fixEqPred (EqPred ty1 ty2) = EqPred ty2 ty2
- dc_tvs = drop (length (dataConUnivTyVars data_con)) pre_dc_tvs ++ dc_eqvars
+ = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
+
+ (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
+ (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
+
+ (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
dc_theta = filter (not . isEqPred) pre_dc_theta
+
arg_base' = arg_base + length dc_theta
unpack_base = arg_base' + length dc_arg_tys
- uniqs = map mkBuiltinUnique [unpack_base..]
+
+ uniq_list = map mkBuiltinUnique [unpack_base..]
+
+ Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+ (co_fn, out_ty) = refineType refinement (idType the_arg_id)
+
+ rhs = ASSERT(out_ty `coreEqType` field_tau) perform_co co_fn (Var the_arg_id)
+
+ perform_co (ExprCoFn co) expr = Cast expr co
+ perform_co id_co expr = ASSERT(isIdCoercion id_co) expr
+
+ -- split the uniq_list into two
+ uniqs = takeHalf uniq_list
+ uniqs' = takeHalf (drop 1 uniq_list)
+
+ takeHalf [] = []
+ takeHalf (h:_:t) = h:(takeHalf t)
+ takeHalf (h:t) = [h]
the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con