- 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
- scrut_id = mkTemplateLocal (dict_id_base+1) scrut_ty
- arg_base = dict_id_base + 2
-
- 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 data_tvs $ mkLams field_tyvars $
- mkLams stupid_dict_ids $ mkLams field_dict_ids $
- Lam data_id $ mk_result sel_body
-
- scrut_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
- scrut_ty = mkTyConApp tycon scrut_ty_args
- scrut = unwrapFamInstScrut tycon scrut_ty_args (Var data_id)
- -- First coerce from the type family to the representation type
-
- -- NB: A newtype always has a vanilla DataCon; no existentials etc
- -- data_tys will simply be the dataConUnivTyVars
- sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon scrut_ty_args scrut
- | otherwise = Case scrut scrut_id field_ty (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
- = ASSERT2( data_ty `tcEqType` field_ty, ppr data_con $$ ppr data_ty $$ ppr field_ty )
- mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs
- where
- -- get pattern binders with types appropriately instantiated
- arg_uniqs = map mkBuiltinUnique [arg_base..]
- (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con scrut_ty_args
-
- rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs
- rebox_uniqs = map mkBuiltinUnique [rebox_base..]
-
- -- data T :: *->* where T1 { fld :: Maybe b } -> T [b]
- -- Hence T1 :: forall a b. (a=[b]) => b -> T a
- -- fld :: forall b. T [b] -> Maybe b
- -- fld = /\b.\(t:T[b]). case t of
- -- T1 b' (c : [b]=[b']) (x:Maybe b')
- -- -> x `cast` Maybe (sym (right c))
-
-
- -- Generate the refinement for b'=b,
- -- and apply to (Maybe b'), to get (Maybe b)
- Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
- the_arg_id_ty = idType the_arg_id
- (rhs, data_ty) = case refineType refinement the_arg_id_ty of
- Just (co, data_ty) -> (Cast (Var the_arg_id) co, data_ty)
- Nothing -> (Var the_arg_id, the_arg_id_ty)
-
- field_vs = filter (not . isPredTy . idType) arg_vs
- the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
- field_lbls = dataConFieldLabels data_con
-
- error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg
- full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])