[project @ 2005-10-17 11:11:15 by simonpj]

Buglets in GADT record-syntax stuff, which killed the weekend builds

3 files changed, 16 insertions, 14 deletions

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 4ff6a0cce1..02d255959c 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -537,14 +537,15 @@ mkRecordSelId tycon field_label
 	(arg_prefix, arg_ids)
 	   | isVanillaDataCon data_con	 	-- Instantiate from commmon base
 	   = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
-	   | otherwise
+	   | otherwise		-- The case pattern binds type variables, which are used
+				-- in the types of the arguments of the pattern
 	   = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
 	      mkTemplateLocalsNum arg_base' dc_arg_tys)
 
 	(dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
 	arg_base' = arg_base + length dc_theta
 
-	unpack_base = arg_base' + length dc_theta
+	unpack_base = arg_base' + length dc_arg_tys
 	uniqs = map mkBuiltinUnique [unpack_base..]
 
     	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index e13b062370..4f9f955765 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -285,18 +285,18 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con [] (L _ []) details))
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
   = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
 	 repConstr con1 details }
-repC (L loc (ConDecl con tvs (L cloc ctxt) details))
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
   = do { addTyVarBinds tvs $ \bndrs -> do {
-             c' <- repC (L loc (ConDecl con [] (L cloc []) details));
+             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
              ctxt' <- repContext ctxt;
              bndrs' <- coreList nameTyConName bndrs;
              rep2 forallCName [unC bndrs', unC ctxt', unC c']
          }
        }
-repC (L loc con_decl)
+repC (L loc con_decl)		-- GADTs
   = putSrcSpanDs loc $ 
     do	{ dsWarn (hang ds_msg 4 (ppr con_decl))
 	; return (panic "DsMeta:repC") }
diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 751623da35..ab9cf2c278 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -105,21 +105,22 @@ cvt_top loc (ForeignD (ExportF callconv as nm typ))
 
 mk_con loc con = L loc $ mk_nlcon con
   where
+	-- Can't handle GADTs yet
     mk_nlcon con = case con of
 	NormalC c strtys
-	 -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
-		  (PrefixCon (map mk_arg strtys))
+	 -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
+		    (PrefixCon (map mk_arg strtys)) ResTyH98
 	RecC c varstrtys
-	 -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
-		  (RecCon (map mk_id_arg varstrtys))
+	 -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
+		  (RecCon (map mk_id_arg varstrtys)) ResTyH98
 	InfixC st1 c st2
-	 -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
-		  (InfixCon (mk_arg st1) (mk_arg st2))
+	 -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
+		  (InfixCon (mk_arg st1) (mk_arg st2)) ResTyH98
 	ForallC tvs ctxt (ForallC tvs' ctxt' con')
 	 -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 	ForallC tvs ctxt con' -> case mk_nlcon con' of
-				ConDecl l [] (L _ []) x ->
-				    ConDecl l (cvt_tvs loc tvs) (cvt_context loc ctxt) x
+				ConDecl l _ [] (L _ []) x ResTyH98 ->
+				    ConDecl l Explicit (cvt_tvs loc tvs) (cvt_context loc ctxt) x ResTyH98
 				c -> panic "ForallC: Can't happen"
     mk_arg (IsStrict, ty)  = L loc $ HsBangTy HsStrict (cvtType loc ty)
     mk_arg (NotStrict, ty) = cvtType loc ty