-\begin{code}
-mkRecordSelId :: TyCon -> FieldLabel -> Id
-mkRecordSelId tycon field_label
- -- Assumes that all fields with the same field label have the same type
- = sel_id
- where
- -- Because this function gets called by implicitTyThings, we need to
- -- produce the OccName of the Id without doing any suspend type checks.
- -- (see the note [Tricky iface loop]).
- -- A suspended type-check is sometimes necessary to compute field_ty,
- -- so we need to make sure that we suspend anything that depends on field_ty.
-
- -- the overall result
- sel_id = mkGlobalId sel_id_details field_label theType theInfo
-
- -- check whether the type is naughty: this thunk does not get forced
- -- until the type is actually needed
- field_ty = dataConFieldType con1 field_label
- is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
-
- -- it's important that this doesn't force the if
- (theType, theInfo) = if is_naughty
- -- Escapist case here for naughty constructors
- -- We give it no IdInfo, and a type of
- -- forall a.a (never looked at)
- then (forall_a_a, noCafIdInfo)
- -- otherwise do the real case
- else (selector_ty, info)
-
- sel_id_details = RecordSelId { sel_tycon = tycon,
- sel_label = field_label,
- sel_naughty = is_naughty }
- -- For a data type family, the tycon is the *instance* TyCon
-
- -- for naughty case
- forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
-
- -- real case starts here:
- 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 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field
- (univ_tvs, _, eq_spec, _, _, _, data_ty) = dataConFullSig con1
- -- For a data type family, the data_ty (and hence selector_ty) mentions
- -- only the family TyCon, not the instance TyCon
- data_tv_set = tyVarsOfType data_ty
- data_tvs = varSetElems data_tv_set
-
- -- *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 data_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!