From 8e1115a7dffc5c6d13da7d7a3daf3f5d5b678d4a Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Sun, 3 Aug 1997 02:19:46 +0000
Subject: [PATCH] [project @ 1997-08-03 02:19:46 by sof] Improved error
messages for derivings of types with wrong shape
---
ghc/compiler/typecheck/TcDeriv.lhs | 31 +++++++++++++++++-------------
1 file changed, 18 insertions(+), 13 deletions(-)
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 58e25a9efcc4..4d2ee6a6acbf 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -48,8 +48,8 @@ import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance,
)
import Outputable ( PprStyle(..), Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
-import Pretty ( ($$), vcat, hsep, hcat,
- ptext, text, char, hang, Doc )
+import Pretty ( ($$), vcat, hsep, hcat, parens,
+ ptext, char, hang, Doc )
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
@@ -236,7 +236,7 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
-- method bindings for the instances.
(dfun_names_w_method_binds, rn_extra_binds)
= renameSourceCode modname rn_name_supply (
- bindLocatedLocalsRn (\_ -> text "deriving") mbinders $ \ _ ->
+ bindLocatedLocalsRn (\_ -> ptext (SLIT("deriving"))) mbinders $ \ _ ->
rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds ->
mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
returnRn (dfun_names_w_method_binds, rn_extra_binds)
@@ -339,20 +339,24 @@ makeDerivEqns
is_enumeration = isEnumerationTyCon tycon
is_single_con = maybeToBool (maybeTyConSingleCon tycon)
- chk_clas clas_uniq clas_str cond
+ single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
+ nullary_why = SLIT("data type with all nullary constructors expected")
+
+ chk_clas clas_uniq clas_str clas_why cond
= if (clas_uniq == clas_key)
- then checkTc cond (derivingThingErr clas_str tycon)
+ then checkTc cond (derivingThingErr clas_str clas_why tycon)
else returnTc ()
in
-- Are things OK for deriving Enum (if appropriate)?
- chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
+ chk_clas enumClassKey (SLIT("Enum")) nullary_why is_enumeration `thenTc_`
-- Are things OK for deriving Bounded (if appropriate)?
- chk_clas boundedClassKey "Bounded"
- (is_enumeration || is_single_con) `thenTc_`
+ chk_clas boundedClassKey (SLIT("Bounded")) single_nullary_why
+ (is_enumeration || is_single_con) `thenTc_`
-- Are things OK for deriving Ix (if appropriate)?
- chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
+ chk_clas ixClassKey (SLIT("Ix.Ix")) single_nullary_why
+ (is_enumeration || is_single_con)
------------------------------------------------------------------
cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
@@ -712,9 +716,10 @@ gen_taggery_Names inst_infos
\end{code}
\begin{code}
-derivingThingErr :: String -> TyCon -> Error
+derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> Error
-derivingThingErr thing tycon sty
- = hang (hsep [ptext SLIT("Can't make a derived instance of"), text thing])
- 4 (hsep [ptext SLIT("for the type"), ppr sty tycon])
+derivingThingErr thing why tycon sty
+ = hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing])
+ 0 (hang (hsep [ptext SLIT("for the type"), ppr sty tycon])
+ 0 (parens (ptext why)))
\end{code}
--
GitLab