-
--- Steps for handling "naughty" vs "non-naughty" selectors:
--- 1. Determine naughtiness by comparing field type vs result type
--- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
--- 3. If it's not naughty, do the normal plan.
-
-mkRecordSelId :: TyCon -> FieldLabel -> Id
-mkRecordSelId tycon field_label
- -- Assumes that all fields with the same field label have the same type
- | is_naughty = naughty_id
- | otherwise = sel_id
- where
- is_naughty = not (tyVarsOfType field_ty `subVarSet` res_tv_set)
- sel_id_details = RecordSelId tycon field_label is_naughty
-
- -- Escapist case here for naughty construcotrs
- -- We give it no IdInfo, and a type of forall a.a (never looked at)
- naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
- forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
-
- -- Normal case starts here
- sel_id = mkGlobalId sel_id_details field_label selector_ty info
- data_cons = tyConDataCons tycon
- data_cons_w_field = filter has_field data_cons -- Can't be empty!
- has_field con = field_label `elem` dataConFieldLabels con
-
- con1 = head data_cons_w_field
- res_tys = dataConResTys con1
- res_tv_set = tyVarsOfTypes res_tys
- res_tvs = varSetElems res_tv_set
- data_ty = mkTyConApp tycon res_tys
- field_ty = dataConFieldType con1 field_label
-
- -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
- -- just the dictionaries in the types of the constructors that contain
- -- the relevant field. [The Report says that pattern matching on a
- -- constructor gives the same constraints as applying it.] Urgh.
- --
- -- However, not all data cons have all constraints (because of
- -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons
- -- involved in the pattern match and take the union of their constraints.
- stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
- n_stupid_dicts = length stupid_dict_tys
-
- (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
- -- If the field has a universally quantified type we have to
- -- be a bit careful. Suppose we have
- -- data R = R { op :: forall a. Foo a => a -> a }
- -- Then we can't give op the type
- -- op :: R -> forall a. Foo a => a -> a
- -- because the typechecker doesn't understand foralls to the
- -- right of an arrow. The "right" type to give it is
- -- op :: forall a. Foo a => R -> a -> a
- -- But then we must generate the right unfolding too:
- -- op = /\a -> \dfoo -> \ r ->
- -- case r of
- -- R op -> op a dfoo
- -- Note that this is exactly the type we'd infer from a user defn
- -- op (R op) = op
-
- selector_ty :: Type
- selector_ty = mkForAllTys res_tvs $ mkForAllTys field_tyvars $
- mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
- mkFunTy data_ty field_tau
-
- 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 res_tvs $ mkLams field_tyvars $
- mkLams stupid_dict_ids $ mkLams field_dict_ids $
- Lam data_id $ mk_result sel_body
-
- -- NB: A newtype always has a vanilla DataCon; no existentials etc
- -- res_tys will simply be the dataConUnivTyVars
- sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id)
- | otherwise = Case (Var data_id) data_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( res_ty `tcEqType` field_ty, ppr data_con $$ ppr res_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 res_tys
-
- 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))
-
- Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
- (co_fn, res_ty) = refineType refinement (idType the_arg_id)
- -- Generate the refinement for b'=b,
- -- and apply to (Maybe b'), to get (Maybe b)
-
- rhs = case co_fn of
- ExprCoFn co -> Cast (Var the_arg_id) co
- id_co -> ASSERT(isIdCoercion id_co) Var the_arg_id
-
- 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])
-