+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 T1 [a,b] [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` \ (tc_tyvars, tc_theta, tc_tau) ->
+ newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) ->
+ let
+ (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau
+ n_args = length tc_arg_tys
+ in
+ newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args ->
+
+ -- Check that all the types of all the strict arguments are in Eval
+ tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
+ let
+ (_,theta,tau) = splitSigmaTy (idType con_id)
+ (arg_tys, _) = splitFunTy tau
+ strict_marks = dataConStrictMarks con_id
+ eval_theta = [ (eval_clas,arg_ty)
+ | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
+ arg_tys strict_marks
+ ]
+ in
+ tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' ->
+ checkTc (null eval_theta')
+ (missingEvalErr con_id eval_theta') `thenTc_`
+
+ -- Build the data constructor
+ let
+ con_rhs = mkHsTyLam tc_tyvars $
+ mkHsDictLam dicts $
+ mk_pat_match args $
+ mk_case (zipEqual "strict_args" args strict_marks) $
+ HsCon con_id (mkTyVarTys tc_tyvars) (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,MarkedStrict):args) body = HsCase (HsVar arg)
+ [PatMatch (VarPat arg) $
+ SimpleMatch (mk_case args body)]
+ src_loc
+ mk_case (_:args) body = mk_case args body
+
+ src_loc = nameSrcLoc (getName con_id)
+ in
+
+ returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
+\end{code}
+