From db1ec79d634e2c502261bfdeb4f2bf3398a61928 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 22 May 2000 06:51:35 +0000
Subject: [PATCH] [project @ 2000-05-22 06:51:35 by simonpj] *** MERGE WITH
 4.07 ***

Correct types of selectors for records with polymorphic fields.
	    (Bug reported by Martin Kowalczyk.)
---
 ghc/compiler/basicTypes/MkId.lhs |   46 +++++++++++++++++++++++++++++++-------
 1 file changed, 38 insertions(+), 8 deletions(-)

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 8d93e73..411c994 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -345,6 +345,33 @@ We're going to build a record selector unfolding that looks like this:
 				    T2 ... x ... -> x
 				    other	 -> error "..."
 
+Similarly for newtypes
+
+	newtype N a = MkN { unN :: a->a }
+
+	unN :: N a -> a -> a
+	unN n = coerce (a->a) n
+	
+We need to take a little care if the field has a polymorphic type:
+
+	data R = R { f :: forall a. a->a }
+
+Then we want
+
+	f :: forall a. R -> a -> a
+	f = /\ a \ r = case r of
+			  R f -> f a
+
+(not f :: R -> forall a. a->a, which gives the type inference mechanism 
+problems at call sites)
+
+Similarly for newtypes
+
+	newtype N = MkN { unN :: forall a. a->a }
+
+	unN :: forall a. N -> a -> a
+	unN = /\a -> \n:N -> coerce (a->a) n
+
 \begin{code}
 mkRecordSelId tycon field_label
 	-- Assumes that all fields with the same field label
@@ -360,8 +387,9 @@ mkRecordSelId tycon field_label
 					-- the FieldLabels of constructors of this type
     tycon_theta	= tyConTheta tycon	-- The context on the data decl
 					--   eg data (Eq a, Ord b) => T a b = ...
+    (field_tyvars,field_tau) = splitForAllTys field_ty
 
-    data_ty   = mkTyConApp tycon (mkTyVarTys tyvars)
+    data_ty   = mkTyConApp tycon tyvar_tys
     tyvar_tys = mkTyVarTys tyvars
 
 	-- Very tiresomely, the selectors are (unnecessarily!) overloaded over
@@ -374,8 +402,8 @@ mkRecordSelId tycon field_label
 			  | (DataAlt dc, _, _) <- the_alts]
 
     selector_ty :: Type
-    selector_ty  = mkForAllTys tyvars $ mkFunTys dict_tys $ 
-		   mkFunTy data_ty field_ty
+    selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
+		   mkFunTys dict_tys $  mkFunTy data_ty field_tau
       
     info = mkIdInfo (RecordSelId field_label)
 	   `setArityInfo`	exactArity 1
@@ -395,23 +423,25 @@ mkRecordSelId tycon field_label
     sel_rhs | isNewTyCon tycon = new_sel_rhs
 	    | otherwise	       = data_sel_rhs
 
-    data_sel_rhs = mkLams tyvars $ mkLams dict_ids $ Lam data_id $
+    data_sel_rhs = mkLams tyvars $ mkLams field_tyvars $ 
+		   mkLams dict_ids $ Lam data_id $
 	 	   Case (Var data_id) data_id (the_alts ++ default_alt)
 
-    new_sel_rhs  = mkLams tyvars $ Lam data_id $
-		    Note (Coerce (unUsgTy field_ty) (unUsgTy data_ty)) (Var data_id)
+    new_sel_rhs  = mkLams tyvars $ mkLams field_tyvars $ Lam data_id $
+		    Note (Coerce (unUsgTy field_tau) (unUsgTy data_ty)) (Var data_id)
 
     mk_maybe_alt data_con 
 	  = case maybe_the_arg_id of
 		Nothing		-> Nothing
-		Just the_arg_id -> Just (DataAlt data_con, arg_ids, Var the_arg_id)
+		Just the_arg_id -> Just (DataAlt data_con, arg_ids, 
+					 mkVarApps (Var the_arg_id) field_tyvars)
 	  where
 	    arg_ids 	     = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 				    -- The first one will shadow data_id, but who cares
 	    field_lbls	     = dataConFieldLabels data_con
 	    maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 
-    error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_ty), mkStringLit full_msg]
+    error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), mkStringLit full_msg]
        -- preserves invariant that type args are *not* usage-annotated on top.  KSW 1999-04.
     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
 \end{code}
-- 
1.7.10.4