From 4dfa61b97b846868698bd352f622d43308c1b761 Mon Sep 17 00:00:00 2001 From: sof Date: Wed, 21 Jan 1998 18:23:15 +0000 Subject: [PATCH] [project @ 1998-01-21 18:23:15 by sof] Fixed panic when deriving Ord on a d. type with a single nullary constructor --- ghc/compiler/typecheck/TcGenDeriv.lhs | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b17d29c..9ac8fdb 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -309,16 +309,30 @@ gen_Ord_binds tycon -- So we need to do a less-than comparison on the tags (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))) + tycon_data_cons = tyConDataCons tycon (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullaryDataCon (tyConDataCons tycon) - - cmp_eq - = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ - if ((length nonnullary_cons + length nullary_cons) == 1) - then [] - else [([WildPatIn, WildPatIn], - default_rhs)]) + | otherwise = partition isNullaryDataCon tycon_data_cons + + cmp_eq = + mk_FunMonoBind tycon_loc + cmp_eq_RDR + (if null nonnullary_cons && (length nullary_cons == 1) then + -- catch this specially to avoid warnings + -- about overlapping patterns from the desugarer. + let + data_con = head nullary_cons + data_con_RDR = qual_orig_name data_con + pat = ConPatIn data_con_RDR [] + in + [([pat,pat], eqTag_Expr)] + else + map pats_etc nonnullary_cons ++ + -- leave out wildcards to silence desugarer. + (if length tycon_data_cons == 1 then + [] + else + [([WildPatIn, WildPatIn], default_rhs)])) where pats_etc data_con = ([con1_pat, con2_pat], -- 1.7.10.4