From 380602804cb003cbe7253bc04e2c627616cce2d2 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 21 Dec 1998 09:37:55 +0000
Subject: [PATCH] [project @ 1998-12-21 09:37:54 by simonpj] Fix two minor
 typechecker bugs

---
 ghc/compiler/typecheck/TcMatches.lhs |    2 +-
 ghc/compiler/typecheck/TcTyDecls.lhs |   23 ++++++++++++++++-------
 2 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 388818b..58ddd03 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -207,7 +207,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
             grhss'' = glue_on Recursive ex_binds $
 		      glue_on Recursive inst_binds grhss'
 	in
-	returnTc (pat_ids, (Match [] pats' Nothing grhss', lie_req''))
+	returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
 
 	-- glue_on just avoids stupid dross
 glue_on _ EmptyMonoBinds grhss = grhss		-- The common case
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 61ad7dc..181f830 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -24,6 +24,7 @@ import TcMonoType	( tcExtendTopTyVarScope, tcExtendTyVarScope,
 			  tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
 			  tcContext
 			)
+import TcType		( zonkTcTyVarToTyVar, zonkTcThetaType )
 import TcEnv		( tcLookupTy, TcTyThing(..) )
 import TcMonad
 import TcUnify		( unifyKind )
@@ -176,13 +177,13 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
 	    tys	        = map get_pty btys
         in
 	mapTc tcHsTopType tys `thenTc` \ arg_tys ->
-	returnTc (mk_data_con arg_stricts arg_tys [])
+	mk_data_con arg_stricts arg_tys []
 
     tc_newcon ty 
       = tcHsTopBoxedType ty	`thenTc` \ arg_ty ->
 	    -- can't allow an unboxed type here, because we're effectively
 	    -- going to remove the constructor while coercing it to a boxed type.
-	returnTc (mk_data_con [NotMarkedStrict] [arg_ty] [])
+	mk_data_con [NotMarkedStrict] [arg_ty] []
 
     tc_rec_con fields
       = checkTc (null ex_tyvars) (exRecConErr name)	    `thenTc_`
@@ -195,21 +196,29 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
 	    field_labels      = [ mkFieldLabel (getName name) ty tag 
 			      | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
 	in
-	returnTc (mk_data_con arg_stricts arg_tys field_labels)
+	mk_data_con arg_stricts arg_tys field_labels
 
     tc_field (field_label_names, bty)
       = tcHsTopType (get_pty bty)	`thenTc` \ field_ty ->
 	returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
 
-    mk_data_con arg_stricts arg_tys fields = data_con
-	where
+    mk_data_con arg_stricts arg_tys fields
+      = 	-- Now we've checked all the field types we must
+		-- zonk the existential tyvars to finish the kind
+		-- inference on their kinds, and commit them to being
+		-- immutable type variables.  (The top-level tyvars are
+		-- already fixed, by the preceding kind-inference pass.)
+	mapNF_Tc zonkTcTyVarToTyVar ex_tyvars	`thenNF_Tc` \ ex_tyvars' ->
+	zonkTcThetaType	ex_theta		`thenNF_Tc` \ ex_theta' ->
+	let
 	   data_con = mkDataCon name arg_stricts fields
 		      	   tyvars (thinContext arg_tys ctxt)
-			   ex_tyvars ex_theta
+			   ex_tyvars' ex_theta'
 		      	   arg_tys
 		      	   tycon data_con_id
 	   data_con_id = mkDataConId data_con
-
+	in
+	returnNF_Tc data_con
 
 -- The context for a data constructor should be limited to
 -- the type variables mentioned in the arg_tys
-- 
1.7.10.4