[commit: ghc] master: Tighten up the side-condition testing for deriving (again) (99a6412)
Simon Peyton Jones
simonpj at microsoft.com
Wed Sep 14 16:28:42 CEST 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/99a6412c9ff5964bd957da79bd3b7d27c4f41228
>---------------------------------------------------------------
commit 99a6412c9ff5964bd957da79bd3b7d27c4f41228
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Sep 14 15:28:25 2011 +0100
Tighten up the side-condition testing for deriving (again)
Fixes Trac #5478
>---------------------------------------------------------------
compiler/typecheck/TcDeriv.lhs | 67 +++++++++++++++++++++++++++----------
compiler/typecheck/TcGenDeriv.lhs | 19 ++++++----
2 files changed, 60 insertions(+), 26 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index c5166c3..1d07a44 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -819,7 +819,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
dataConInstOrigArgTys data_con all_rep_tc_args,
not (isUnLiftedType arg_ty) ]
-- No constraints for unlifted types
- -- Where they are legal we generate specilised function calls
+ -- See Note [Deriving and unboxed types]
-- For functor-like classes, two things are different
-- (a) We recurse over argument types to generate constraints
@@ -860,7 +860,24 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
= [mkClassPred cls [ty] | ty <- rep_tc_args]
| otherwise
= []
+\end{code}
+
+Note [Deriving and unboxed types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have some special hacks to support things like
+ data T = MkT Int# deriving( Ord, Show )
+
+Specifically
+ * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
+ (which we know how to show)
+
+ * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
+ on some primitive types
+
+It's all a bit ad hoc.
+
+\begin{code}
------------------------------------------------------------------
-- Check side conditions that dis-allow derivability for particular classes
-- This is *apart* from the newtype-deriving mechanism
@@ -894,15 +911,15 @@ nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
sideConditions :: DerivContext -> Class -> Maybe Condition
sideConditions mtheta cls
- | 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 == eqClassKey = Just (cond_std `andCond` cond_args cls)
+ | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
+ | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
+ | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls)
| 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 == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
+ | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
| cls_key == dataClassKey = Just (checkFlag Opt_DeriveDataTypeable `andCond`
- cond_std `andCond` cond_noUnliftedArgs)
+ cond_std `andCond` cond_args cls)
| cls_key == functorClassKey = Just (checkFlag Opt_DeriveFunctor `andCond`
cond_functorOK True) -- NB: no cond_std!
| cls_key == foldableClassKey = Just (checkFlag Opt_DeriveFoldable `andCond`
@@ -964,20 +981,34 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
cond_RepresentableOk :: Condition
cond_RepresentableOk (_,t) = canDoGenerics t
-cond_enumOrProduct :: Condition
-cond_enumOrProduct = cond_isEnumeration `orCond`
- (cond_isProduct `andCond` cond_noUnliftedArgs)
+cond_enumOrProduct :: Class -> Condition
+cond_enumOrProduct cls = cond_isEnumeration `orCond`
+ (cond_isProduct `andCond` cond_args cls)
-cond_noUnliftedArgs :: Condition
+cond_args :: Class -> 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
+cond_args cls (_, tc)
+ = case bad_args of
+ [] -> Nothing
+ (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
+ 2 (ptext (sLit "for type") <+> quotes (ppr ty)))
where
- bad_cons = [ con | con <- tyConDataCons tc
- , any isUnLiftedType (dataConOrigArgTys con) ]
- why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
+ bad_args = [ arg_ty | con <- tyConDataCons tc
+ , arg_ty <- dataConOrigArgTys con
+ , isUnLiftedType arg_ty
+ , not (ok_ty arg_ty) ]
+
+ cls_key = classKey cls
+ ok_ty arg_ty
+ | cls_key == eqClassKey = check_in arg_ty ordOpTbl
+ | cls_key == ordClassKey = check_in arg_ty ordOpTbl
+ | cls_key == showClassKey = check_in arg_ty boxConTbl
+ | otherwise = False -- Read, Ix etc
+
+ check_in :: Type -> [(Type,a)] -> Bool
+ check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
+
cond_isEnumeration :: Condition
cond_isEnumeration (_, rep_tc)
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 12df4b5..ad06d6e 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -28,7 +28,8 @@ module TcGenDeriv (
deepSubtypesContaining, foldDataConArgs,
gen_Foldable_binds,
gen_Traversable_binds,
- genAuxBind
+ genAuxBind,
+ ordOpTbl, boxConTbl
) where
#include "HsVersions.h"
@@ -1821,21 +1822,23 @@ box_if_necy :: String -- The class involved
-> LHsExpr RdrName -- The argument
-> Type -- The argument type
-> LHsExpr RdrName -- Boxed version of the arg
+-- See Note [Deriving and unboxed types]
box_if_necy cls_str tycon arg arg_ty
| isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
| otherwise = arg
where
- box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
+ box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
---------------------
primOrdOps :: String -- The class involved
-> TyCon -- The tycon involved
-> Type -- The type
-> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
-primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
+-- See Note [Deriving and unboxed types]
+primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
-ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
-ord_op_tbl
+ordOpTbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
+ordOpTbl
= [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
@@ -1843,9 +1846,9 @@ ord_op_tbl
,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
-box_con_tbl :: [(Type, RdrName)]
-box_con_tbl =
- [(charPrimTy, getRdrName charDataCon)
+boxConTbl :: [(Type, RdrName)]
+boxConTbl
+ = [(charPrimTy, getRdrName charDataCon)
,(intPrimTy, getRdrName intDataCon)
,(wordPrimTy, wordDataCon_RDR)
,(floatPrimTy, getRdrName floatDataCon)
More information about the Cvs-ghc
mailing list