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.

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 8fa6feb..b943a99 100644 (file)
--- 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 (file)
--- 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 "=",