+ ast :: Q [Dec]
+ ast = [d| instance Numeric Int |]
+
+When we typecheck 'ast' we have done the first pass over the class decl
+(in tcTyClDecls), but we have not yet typechecked the default-method
+declarations (becuase they can mention value declarations). So we
+must bring the default method Ids into scope first (so they can be seen
+when typechecking the [d| .. |] quote, and typecheck them later.
+
+\begin{code}
+mkRecSelBinds :: [TyThing] -> HsValBinds Name
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+-- This makes life easier, because the later type checking will add
+-- all necessary type abstractions and applications
+mkRecSelBinds ty_things
+ = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
+ where
+ (sigs, binds) = unzip rec_sels
+ rec_sels = map mkRecSelBind [ (tc,fld)
+ | ATyCon tc <- ty_things
+ , fld <- tyConFields tc ]
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
+mkRecSelBind (tycon, sel_name)
+ = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
+ where
+ loc = getSrcSpan tycon
+ sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
+ rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
+
+ -- Find a representative constructor, con1
+ all_cons = tyConDataCons tycon
+ cons_w_field = [ con | con <- all_cons
+ , sel_name `elem` dataConFieldLabels con ]
+ con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+
+ -- Selector type; Note [Polymorphic selectors]
+ field_ty = dataConFieldType con1 sel_name
+ data_ty = dataConOrigResTy con1
+ data_tvs = tyVarsOfType data_ty
+ is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
+ (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+ sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
+ | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
+ mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
+ mkPhiTy field_theta $ -- Urgh!
+ mkFunTy data_ty field_tau
+
+ -- Make the binding: sel (C2 { fld = x }) = x
+ -- sel (C7 { fld = x }) = x
+ -- where cons_w_field = [C2,C7]
+ sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
+ | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
+ mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
+ (L loc (HsVar field_var))
+ mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
+ rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
+ rec_field = HsRecField { hsRecFieldId = sel_lname
+ , hsRecFieldArg = nlVarPat field_var
+ , hsRecPun = False }
+ sel_lname = L loc sel_name
+ field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
+
+ -- Add catch-all default case unless the case is exhaustive
+ -- We do this explicitly so that we get a nice error message that
+ -- mentions this particular record selector
+ deflt | not (any is_unused all_cons) = []
+ | otherwise = [mkSimpleMatch [nlWildPat]
+ (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
+ (nlHsLit msg_lit))]
+
+ -- Do not add a default case unless there are unmatched
+ -- constructors. We must take account of GADTs, else we
+ -- get overlap warning messages from the pattern-match checker
+ is_unused con = not (con `elem` cons_w_field
+ || dataConCannotMatch inst_tys con)
+ inst_tys = tyConAppArgs data_ty
+
+ unit_rhs = mkLHsTupleExpr []
+ msg_lit = HsStringPrim $ mkFastString $
+ occNameString (getOccName sel_name)
+
+---------------
+tyConFields :: TyCon -> [FieldLabel]
+tyConFields tc
+ | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
+ | otherwise = []
+\end{code}