Commit 9137abfe authored by simonpj's avatar simonpj

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

Buglets in GADT record-syntax stuff, which killed the weekend builds
parent b16992d6
......@@ -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
......
......@@ -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") }
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment