From: simonpj <unknown>
Date: Mon, 3 Dec 2001 11:45:32 +0000 (+0000)
Subject: [project @ 2001-12-03 11:45:32 by simonpj]
X-Git-Tag: Approximately_9120_patches~481
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3178cb8bf5907b4c42fd3b643fc2dd073c2cd2e4;p=ghc-hetmet.git

[project @ 2001-12-03 11:45:32 by simonpj]
Dont fall over on data T deriving(Show)
---

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 54a8e72..e3fba55 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -320,7 +320,8 @@ makeDerivEqns tycl_decls
 		 ]
 	in
 	case chk_out clas tycon of
-	   Just err ->  addErrTc err				`thenNF_Tc_` 
+	   Just err ->  tcAddSrcLoc (getSrcLoc tycon)	$
+			addErrTc err			`thenNF_Tc_` 
 			returnNF_Tc Nothing
 	   Nothing  ->  newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name ->
 			returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints))
@@ -330,18 +331,21 @@ makeDerivEqns tycl_decls
     ------------------------------------------------------------------
     chk_out :: Class -> TyCon -> Maybe Message
     chk_out clas tycon
-	| clas `hasKey` enumClassKey    && not is_enumeration 	      = bog_out nullary_why
+	| clas `hasKey` enumClassKey    && not is_enumeration 	        = bog_out nullary_why
 	| clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why
 	| clas `hasKey` ixClassKey      && not is_enumeration_or_single = bog_out single_nullary_why
-	| any isExistentialDataCon (tyConDataCons tycon)	      = Just (existentialErr clas tycon)
-	| otherwise						      = Nothing
+	| null data_cons		     = bog_out no_cons_why
+	| any isExistentialDataCon data_cons = Just (existentialErr clas tycon)
+	| otherwise			     = Nothing
 	where
+	    data_cons = tyConDataCons tycon
 	    is_enumeration = isEnumerationTyCon tycon
 	    is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
 	    is_enumeration_or_single = is_enumeration || is_single_con
 
 	    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")
+	    no_cons_why	       = SLIT("type has no data constructors")
 
 	    bog_out why = Just (derivingThingErr clas tycon why)
 \end{code}