= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
+ tcConstructor pat name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+
+ -- Check overall type matches (c.f. tcConPat)
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) ->
let
-- Don't use zipEqual! If the constructor isn't really a record, then
-- dataConFieldLabels will be empty (and each field in the pattern
in
-- Check the fields
- tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req2, tvs, ids, lie_avail2) ->
returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
- lie_req,
+ lie_req1 `plusLIE` lie_req2,
listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
------------------------------------------------------
\begin{code}
-tcConstructor pat con_name pat_ty
+tcConstructor pat con_name
= -- Check that it's a constructor
tcLookupDataCon con_name `thenNF_Tc` \ data_con ->
in
newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
- -- Check overall type matches
- unifyTauTy pat_ty result_ty `thenTc_`
-
- returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys')
+ returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty)
\end{code}
------------------------------------------------------
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
+ tcConstructor pat con_name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+
+ -- Check overall type matches.
+ -- The pat_ty might be a for-all type, in which
+ -- case we must instantiate to match
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) ->
-- Check correct arity
let
(arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
-- Check arguments
- tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
+ tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req2, tvs, ids, lie_avail2) ->
- returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
- lie_req,
- listToBag ex_tvs' `unionBags` tvs,
+ returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats',
+ lie_req1 `plusLIE` lie_req2,
+ listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
\end{code}