| ... |
... |
@@ -4787,6 +4787,7 @@ checkValidTyCl tc |
|
4787
|
4787
|
= setSrcSpan (getSrcSpan tc) $
|
|
4788
|
4788
|
addTyConCtxt tc $
|
|
4789
|
4789
|
recoverM recovery_code $
|
|
|
4790
|
+ checkNoErrs $
|
|
4790
|
4791
|
do { traceTc "Starting validity for tycon" (ppr tc)
|
|
4791
|
4792
|
; checkValidTyCon tc
|
|
4792
|
4793
|
; checkTyConConsistentWithBoot tc -- See Note [TyCon boot consistency checking]
|
| ... |
... |
@@ -4991,7 +4992,7 @@ checkValidTyCon tc |
|
4991
|
4992
|
check_fields ((label, con1) :| other_fields)
|
|
4992
|
4993
|
-- These fields all have the same name, but are from
|
|
4993
|
4994
|
-- different constructors in the data type
|
|
4994
|
|
- = recoverM (return ()) $ mapM_ checkOne other_fields
|
|
|
4995
|
+ = mapM_ checkOne other_fields
|
|
4995
|
4996
|
-- Check that all the fields in the group have the same type
|
|
4996
|
4997
|
-- NB: this check assumes that all the constructors of a given
|
|
4997
|
4998
|
-- data type use the same type variables
|
| ... |
... |
@@ -5001,8 +5002,10 @@ checkValidTyCon tc |
|
5001
|
5002
|
lbl = flLabel label
|
|
5002
|
5003
|
|
|
5003
|
5004
|
checkOne (_, con2) -- Do it both ways to ensure they are structurally identical
|
|
5004
|
|
- = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
|
|
5005
|
|
- ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
|
|
|
5005
|
+ = do { ((), no_errs) <- askNoErrs $
|
|
|
5006
|
+ checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
|
|
|
5007
|
+ ; when no_errs $
|
|
|
5008
|
+ checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
|
|
5006
|
5009
|
where
|
|
5007
|
5010
|
res2 = dataConOrigResTy con2
|
|
5008
|
5011
|
fty2 = dataConFieldType con2 lbl
|
| ... |
... |
@@ -5029,8 +5032,8 @@ checkPartialRecordField all_cons fld |
|
5029
|
5032
|
checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
|
|
5030
|
5033
|
-> Type -> Type -> Type -> Type -> TcM ()
|
|
5031
|
5034
|
checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
|
|
5032
|
|
- = do { checkTc (isJust mb_subst1) (TcRnCommonFieldResultTypeMismatch con1 con2 fld)
|
|
5033
|
|
- ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) }
|
|
|
5035
|
+ = do { unless (isJust mb_subst1) (addErrTc $ TcRnCommonFieldResultTypeMismatch con1 con2 fld)
|
|
|
5036
|
+ ; unless (isJust mb_subst2) (addErrTc $ TcRnCommonFieldTypeMismatch con1 con2 fld) }
|
|
5034
|
5037
|
where
|
|
5035
|
5038
|
mb_subst1 = tcMatchTy res1 res2
|
|
5036
|
5039
|
mb_subst2 = tcMatchTyX (expectJust mb_subst1) fty1 fty2
|