summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
1da6efa)
MERGE 4.07
* Another wibble on records
boxedTypeKind, mkArrowKind,
tidyOpenType
)
boxedTypeKind, mkArrowKind,
tidyOpenType
)
-import TyCon ( tyConTyVars )
+import TyCon ( TyCon, tyConTyVars )
import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
import Subst ( mkTopTyVarSubst, substClasses, substTy )
import UsageSPUtils ( unannotTy )
import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet )
tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
(_, record_ty) = splitFunTys con_tau
tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
(_, record_ty) = splitFunTys con_tau
+ (tycon, ty_args, _) = splitAlgTyConApp record_ty
in
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
unifyTauTy res_ty record_ty `thenTc_`
in
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
unifyTauTy res_ty record_ty `thenTc_`
else
-- Typecheck the record bindings
else
-- Typecheck the record bindings
- tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ tcRecordBinds tycon ty_args rbinds `thenTc` \ (rbinds', rbinds_lie) ->
let
missing_s_fields = missingStrictFields rbinds data_con
let
missing_s_fields = missingStrictFields rbinds data_con
result_record_ty = mkTyConApp tycon result_inst_tys
in
unifyTauTy res_ty result_record_ty `thenTc_`
result_record_ty = mkTyConApp tycon result_inst_tys
in
unifyTauTy res_ty result_record_ty `thenTc_`
- tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ tcRecordBinds tycon result_inst_tys rbinds `thenTc` \ (rbinds', rbinds_lie) ->
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
\begin{code}
tcRecordBinds
\begin{code}
tcRecordBinds
- :: TcType -- Expected type of whole record
+ :: TyCon -- Type constructor for the record
+ -> [TcType] -- Args of this type constructor
-> RenamedRecordBinds
-> TcM s (TcRecordBinds, LIE)
-> RenamedRecordBinds
-> TcM s (TcRecordBinds, LIE)
-tcRecordBinds expected_record_ty rbinds
- = tcLookupValue first_field_lbl_name `thenNF_Tc` \ first_sel_id ->
- let
- tycon = fieldLabelTyCon (recordSelectorFieldLabel first_sel_id)
- in
- tcInstTyVars (tyConTyVars tycon) `thenTc` \ (_, arg_tys, tenv) ->
- unifyTauTy expected_record_ty
- (mkTyConApp tycon arg_tys) `thenTc_`
- mapAndUnzipTc (do_bind tycon tenv) rbinds `thenTc` \ (rbinds', lies) ->
+tcRecordBinds tycon ty_args rbinds
+ = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
returnTc (rbinds', plusLIEs lies)
where
returnTc (rbinds', plusLIEs lies)
where
- (first_field_lbl_name, _, _) = head rbinds
+ tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
- do_bind tycon tenv (field_lbl_name, rhs, pun_flag)
+ do_bind (field_lbl_name, rhs, pun_flag)
= tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id ->
let
field_lbl = recordSelectorFieldLabel sel_id
= tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id ->
let
field_lbl = recordSelectorFieldLabel sel_id