- 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!
+ sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
+ -- We can't just say (exprType rhs), because that would give a type
+ -- C a -> C a
+ -- for a single-op class (after all, the selector is the identity)
+ -- But it's type must expose the representation of the dictionary
+ -- to get (say) C a -> (a -> a)
+
+ base_info = noCafIdInfo
+ `setArityInfo` 1
+ `setStrictnessInfo` Just strict_sig
+ `setUnfoldingInfo` (if no_unf then noUnfolding
+ else mkImplicitUnfolding rhs)
+ -- In module where class op is defined, we must add
+ -- the unfolding, even though it'll never be inlined
+ -- becuase we use that to generate a top-level binding
+ -- for the ClassOp
+
+ info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
+ -- See Note [Single-method classes] for why alwaysInlinePragma
+ | otherwise = base_info `setSpecInfo` mkSpecInfo [rule]
+ `setInlinePragInfo` neverInlinePragma
+ -- Add a magic BuiltinRule, and never inline it
+ -- so that the rule is always available to fire.
+ -- See Note [ClassOp/DFun selection] in TcInstDcls
+
+ n_ty_args = length tyvars
+
+ -- This is the built-in rule that goes
+ -- op (dfT d1 d2) ---> opT d1 d2
+ rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
+ occNameFS (getOccName name)
+ , ru_fn = name
+ , ru_nargs = n_ty_args + 1
+ , ru_try = dictSelRule val_index n_ty_args n_eq_args }
+
+ -- The strictness signature is of the form U(AAAVAAAA) -> T
+ -- where the V depends on which item we are selecting
+ -- It's worth giving one, so that absence info etc is generated
+ -- even if the selector isn't inlined
+ strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
+ arg_dmd | new_tycon = evalDmd
+ | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+ | id <- arg_ids ])
+
+ tycon = classTyCon clas
+ new_tycon = isNewTyCon tycon
+ [data_con] = tyConDataCons tycon
+ tyvars = dataConUnivTyVars data_con
+ arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
+ eq_theta = dataConEqTheta data_con
+ n_eq_args = length eq_theta
+
+ -- 'index' is a 0-index into the *value* arguments of the dictionary
+ val_index = assoc "MkId.mkDictSelId" sel_index_prs name
+ sel_index_prs = map idName (classAllSelIds clas) `zip` [0..]
+
+ the_arg_id = arg_ids !! val_index
+ pred = mkClassPred clas (mkTyVarTys tyvars)
+ dict_id = mkTemplateLocal 1 $ mkPredTy pred
+ arg_ids = mkTemplateLocalsNum 2 arg_tys
+ eq_ids = map mkWildEvBinder eq_theta
+
+ rhs = mkLams tyvars (Lam dict_id rhs_body)
+ rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
+ | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
+ [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+
+dictSelRule :: Int -> Arity -> Arity
+ -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+-- Tries to persuade the argument to look like a constructor
+-- application, using exprIsConApp_maybe, and then selects
+-- from it
+-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
+--
+dictSelRule val_index n_ty_args n_eq_args id_unf args
+ | (dict_arg : _) <- drop n_ty_args args
+ , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
+ , let val_args = drop n_eq_args con_args
+ = Just (val_args !! val_index)
+ | otherwise
+ = Nothing
+\end{code}