From 4dfa61b97b846868698bd352f622d43308c1b761 Mon Sep 17 00:00:00 2001
From: sof <unknown>
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 b17d29ced4f5..9ac8fdb46cac 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],
--
GitLab