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

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

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 4ff6a0c..02d2559 100644 (file)
--- 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 e13b062..4f9f955 100644 (file)
--- 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 751623d..ab9cf2c 100644 (file)
--- 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