-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}
-
-We're going to build a record selector that looks like this:
-
- data T a b c = T1 { op :: a, ...}
- | T2 { op :: a, ...}
- | T3
-
- sel :: forall a b c. T a b c -> a
- sel = /\ a b c -> \ T1 { sel = x } -> x
- T2 { sel = 2 } -> x
-
-Note that the selector Id itself is used as the field
-label; it has to be an Id, you see!
-