+We're going to build a constructor that looks like:
+
+ data (Data a, C b) => T a b = T1 !a !Int b
+
+ T1 = /\ a b ->
+ \d1::Data a, d2::C b ->
+ \p q r -> case p of { p ->
+ case q of { q ->
+ HsCon [a,b,c] [p,q,r]}}
+
+Notice that
+
+* d2 is thrown away --- a context in a data decl is used to make sure
+ one *could* construct dictionaries at the site the constructor
+ is used, but the dictionary isn't actually used.
+
+* We have to check that we can construct Data dictionaries for
+ the types a and Int. Once we've done that we can throw d1 away too.
+
+* We use (case p of ...) to evaluate p, rather than "seq" because
+ all that matters is that the arguments are evaluated. "seq" is
+ very careful to preserve evaluation order, which we don't need
+ to be here.
+
+\begin{code}
+mkConstructor con_id
+ | not (isLocallyDefinedName (getName con_id))
+ = returnTc (con_id, EmptyMonoBinds)
+
+ | otherwise -- It is locally defined
+ = tcInstId con_id `thenNF_Tc` \ (tyvars, theta, tau) ->
+ newDicts DataDeclOrigin theta `thenNF_Tc` \ (_, dicts) ->
+ let
+ (arg_tys, result_ty) = splitFunTy tau
+ n_args = length arg_tys
+ in
+ newLocalIds (take n_args (repeat SLIT("con"))) arg_tys `thenNF_Tc` {- \ pre_zonk_args ->
+ mapNF_Tc zonkId pre_zonk_args `thenNF_Tc` -} \ args ->
+
+ -- Check that all the types of all the strict
+ -- arguments are in Data. This is trivially true of everything except
+ -- type variables, for which we must check the context.
+ let
+ strict_marks = dataConStrictMarks con_id
+ strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
+
+ data_tyvars = -- The tyvars in the constructor's context that are arguments
+ -- to the Data class
+ [getTyVar "mkConstructor" ty
+ | (clas,ty) <- theta,
+ uniqueOf clas == dataClassKey]
+
+ check_data arg = case getTyVar_maybe (tcIdType arg) of
+ Nothing -> returnTc () -- Not a tyvar, so OK
+ Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
+ in
+ mapTc check_data strict_args `thenTc_`
+
+ -- Build the data constructor
+ let
+ con_rhs = mkHsTyLam tyvars $
+ DictLam dicts $
+ mk_pat_match args $
+ mk_case strict_args $
+ HsCon con_id arg_tys (map HsVar args)
+
+ mk_pat_match [] body = body
+ mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
+
+ mk_case [] body = body
+ mk_case (arg:args) body = HsCase (HsVar arg)
+ [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))]
+ src_loc
+
+ src_loc = nameSrcLoc (getName con_id)
+ in
+
+ returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
+\end{code}
+