From 6b1a6f305f801a1e2a90c3b513e76e7c2d221499 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Sat, 25 Oct 2008 17:12:11 +0000
Subject: [PATCH] Fix Trac #2701: make deriving check better for unlifted args

Getting the automatic deriving mechanism to work really smoothly
is surprisingly hard.  I keep finding myself in TcDeriv!

Anyway, this is a nice clean fix to Trac #2701.
---
 compiler/typecheck/TcDeriv.lhs    |   36 +++++++++++++++++++++++++++---------
 compiler/typecheck/TcGenDeriv.lhs |    9 +++------
 2 files changed, 30 insertions(+), 15 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 8fa6feb..b943a99 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -615,7 +615,9 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 	          | data_con <- tyConDataCons rep_tc,
 	            arg_ty   <- ASSERT( isVanillaDataCon data_con )
 				dataConInstOrigArgTys data_con rep_tc_args,
-	            not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
+	            not (isUnLiftedType arg_ty) ]
+			-- No constraints for unlifted types
+			-- Where they are legal we generate specilised function calls
 
 			-- See Note [Superclasses of derived instance]
 	      sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
@@ -692,14 +694,14 @@ nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
 
 sideConditions :: Class -> Maybe Condition
 sideConditions cls
-  | cls_key == eqClassKey   = Just cond_std
-  | cls_key == ordClassKey  = Just cond_std
-  | cls_key == readClassKey = Just cond_std
-  | cls_key == showClassKey = Just cond_std
-  | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
-  | cls_key == ixClassKey   = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
-  | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
-  | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
+  | cls_key == eqClassKey      = Just cond_std
+  | cls_key == ordClassKey     = Just cond_std
+  | cls_key == showClassKey    = Just cond_std
+  | cls_key == readClassKey    = Just (cond_std `andCond` cond_noUnliftedArgs)
+  | cls_key == enumClassKey    = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey      = Just (cond_std `andCond` cond_enumOrProduct)
+  | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
+  | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
   | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
   | otherwise = Nothing
   where
@@ -737,6 +739,22 @@ cond_std (_, rep_tc)
     existential_why = quotes (pprSourceTyCon rep_tc) <+> 
 		      ptext (sLit "has non-Haskell-98 constructor(s)")
   
+cond_enumOrProduct :: Condition
+cond_enumOrProduct = cond_isEnumeration `orCond` 
+		       (cond_isProduct `andCond` cond_noUnliftedArgs)
+
+cond_noUnliftedArgs :: Condition
+-- For some classes (eg Eq, Ord) we allow unlifted arg types
+-- by generating specilaised code.  For others (eg Data) we don't.
+cond_noUnliftedArgs (_, tc)
+  | null bad_cons = Nothing
+  | otherwise     = Just why
+  where
+    bad_cons = [ con | con <- tyConDataCons tc
+		     , any isUnLiftedType (dataConOrigArgTys con) ]
+    why = ptext (sLit "Constructor") <+> quotes (ppr (head bad_cons))
+	  <+> ptext (sLit "has arguments of unlifted type")
+
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
   | isEnumerationTyCon rep_tc = Nothing
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 0eabe32..9826f2f 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -688,9 +688,7 @@ gen_Ix_binds loc tycon
     data_con
       =	case tyConSingleDataCon_maybe tycon of -- just checking...
 	  Nothing -> panic "get_Ix_binds"
-	  Just dc | any isUnLiftedType (dataConOrigArgTys dc)
-		  -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
-		  | otherwise -> dc
+	  Just dc -> dc
 
     con_arity    = dataConSourceArity data_con
     data_con_RDR = getRdrName data_con
@@ -898,9 +896,8 @@ gen_Read_binds get_fixity loc tycon
     data_con_str con = occNameString (getOccName con)
     
     read_punc c = bindLex (punc_pat c)
-    read_arg a ty 
-	| isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
-	| otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
+    read_arg a ty = ASSERT( not (isUnLiftedType ty) )
+                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
     
     read_field lbl a = read_lbl lbl ++
     		       [read_punc "=",
-- 
1.7.10.4