From 074d99bd864680f896b671fa354fcca6be77ae12 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 20 Apr 2000 10:56:05 +0000
Subject: [PATCH] [project @ 2000-04-20 10:56:05 by simonpj] - Fix bug in
TcExpr.tcMonoExpr (RecordUpd ...), where I hadn't propagated the recent
change (to be H98ish) that record selectors for types with a context are
overloaded: data Eq a => T a { f1 :: a }
Here f1 :: Eq a => T a -> a
I don't like this, but Mark persuaded me that this was the
Right Thing if we are to have contexts in data decls at all
(which we should not)
---
ghc/compiler/deSugar/DsExpr.lhs | 4 ++--
ghc/compiler/typecheck/TcExpr.lhs | 9 +++++----
2 files changed, 7 insertions(+), 6 deletions(-)
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index e1023c2b63a4..ea1eeebea2fd 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -32,7 +32,7 @@ import Match ( matchWrapper, matchSimply )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
-import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
+import DataCon ( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels )
import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
@@ -507,7 +507,7 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConId con))
+ rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConWrapId con))
out_inst_tys)
dicts)
val_args
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 806396117119..100a838a7ba1 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -57,8 +57,8 @@ import Name ( Name, getName )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
ipName_maybe,
splitFunTy_maybe, splitFunTys, isNotUsgTy,
- mkTyConApp,
- splitForAllTys, splitRhoTy,
+ mkTyConApp, splitSigmaTy,
+ splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
boxedTypeKind, mkArrowKind,
@@ -562,8 +562,9 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
-- Figure out the tycon and data cons from the first field name
let
(Just sel_id : _) = maybe_sel_ids
- (_, tau) = ASSERT( isNotUsgTy (idType sel_id) )
- splitForAllTys (idType sel_id)
+ (_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) )
+ splitSigmaTy (idType sel_id) -- Selectors can be overloaded
+ -- when the data type has a context
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
(tycon, _, data_cons) = splitAlgTyConApp data_ty
(con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
--
GitLab