+ arity = 1 + n_stupid_dicts + n_field_dict_tys
+
+ (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
+ -- Use the demand analyser to work out strictness.
+ -- With all this unpackery it's not easy!
+
+ info = noCafIdInfo
+ `setCafInfo` caf_info
+ `setArityInfo` arity
+ `setUnfoldingInfo` mkTopUnfolding rhs_w_str
+ `setAllStrictnessInfo` Just strict_sig
+
+ -- Allocate Ids. We do it a funny way round because field_dict_tys is
+ -- almost always empty. Also note that we use max_dict_tys
+ -- rather than n_dict_tys, because the latter gives an infinite loop:
+ -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
+ -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
+ stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
+ max_stupid_dicts = length (tyConStupidTheta tycon)
+ field_dict_base = max_stupid_dicts + 1
+ field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
+ dict_id_base = field_dict_base + n_field_dict_tys
+ data_id = mkTemplateLocal dict_id_base data_ty
+ arg_base = dict_id_base + 1
+
+ the_alts :: [CoreAlt]
+ the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con
+ no_default = length data_cons == length data_cons_w_field -- No default needed
+
+ default_alt | no_default = []
+ | otherwise = [(DEFAULT, [], error_expr)]
+
+ -- The default branch may have CAF refs, because it calls recSelError etc.
+ caf_info | no_default = NoCafRefs
+ | otherwise = MayHaveCafRefs
+
+ sel_rhs = mkLams tyvars $ mkLams field_tyvars $
+ mkLams stupid_dict_ids $ mkLams field_dict_ids $
+ Lam data_id $ sel_body
+
+ sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
+ | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
+
+ mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
+ -- We pull the field lambdas to the top, so we need to
+ -- apply them in the body. For example:
+ -- data T = MkT { foo :: forall a. a->a }
+ --
+ -- foo :: forall a. T -> a -> a
+ -- foo = /\a. \t:T. case t of { MkT f -> f a }
+
+ 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)
+ (mk_result (Var the_arg_id))
+ 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_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
+ mkTemplateLocalsNum arg_base' dc_arg_tys)
+
+ (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
+ arg_base' = arg_base + length dc_theta
+
+ unpack_base = arg_base' + length dc_arg_tys
+ uniqs = map mkBuiltinUnique [unpack_base..]
+
+ the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
+ field_lbls = dataConFieldLabels data_con
+
+ error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
+ full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])