Commit 1a911f21 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Sequester deriving-related validity check into cond_stdOK

Currently, any standalone-derived instance must satisfy the
property that the tycon of the data type having an instance being
derived for it must be either a normal ADT tycon or a data family
tycon. But there are several other primitive tycons—such as `(->)`,
`Int#`, and others—which cannot have standalone-derived instances
(via the `anyclass` strategy) as a result of this check! See
https://ghc.haskell.org/trac/ghc/ticket/13154#comment:8 for an
example of where this overly conservative restriction bites.

Really, this validity check only makes sense in the context of
`stock` deriving, where we need the property that the tycon is that
of a normal ADT or a data family in order to inspect its data
constructors. Other deriving strategies don't require this validity
check, so the most sensible way to fix this error is to move the
logic of this check into `cond_stdOK`, which is specific to
`stock` deriving.

This makes progress towards fixing (but does not entirely fix)

Test Plan: make test TEST=T13154a

Reviewers: bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #13154

Differential Revision: https://phabricator.haskell.org/D4337
parent be84823b
......@@ -638,11 +638,10 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
-> do warnUselessTypeable
return Nothing
| isAlgTyCon tc || isDataFamilyTyCon tc -- All other classes
-> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
tvs cls cls_tys tc tc_args
(Just theta) deriv_strat
; return $ Just spec }
| otherwise
-> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
tvs cls cls_tys tc tc_args
(Just theta) deriv_strat
_ -> -- Complain about functions, primitive types, etc,
bale_out $
......@@ -1097,12 +1096,13 @@ mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
-> (SDoc -> DerivM EarlyDerivSpec)
-> DerivM EarlyDerivSpec
mk_eqn_stock go_for_it bale_out
= do DerivEnv { denv_rep_tc = rep_tc
= do DerivEnv { denv_tc = tc
, denv_rep_tc = rep_tc
, denv_cls = cls
, denv_cls_tys = cls_tys
, denv_mtheta = mtheta } <- ask
dflags <- getDynFlags
case checkSideConditions dflags mtheta cls cls_tys rep_tc of
case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
CanDerive -> mk_eqn_stock' go_for_it
DerivableClassError msg -> bale_out msg
_ -> bale_out (nonStdErr cls)
......@@ -1146,7 +1146,7 @@ mk_eqn_no_mechanism go_for_it bale_out
| otherwise
= nonStdErr cls $$ msg
case checkSideConditions dflags mtheta cls cls_tys rep_tc of
case checkSideConditions dflags mtheta cls cls_tys tc rep_tc of
-- NB: pass the *representation* tycon to checkSideConditions
NonDerivableClass msg -> bale_out (dac_error msg)
DerivableClassError msg -> bale_out msg
......@@ -1361,7 +1361,8 @@ mkNewTypeEqn
|| std_class_via_coercible cls)
-> go_for_it_gnd
| otherwise
-> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
-> case checkSideConditions dflags mtheta cls cls_tys
tycon rep_tycon of
DerivableClassError msg
-- There's a particular corner case where
--
......
......@@ -418,11 +418,11 @@ getDataConFixityFun tc
-- family tycon (with indexes) in error messages.
checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-> TyCon -- tycon
-> TyCon -> TyCon
-> DerivStatus
checkSideConditions dflags mtheta cls cls_tys rep_tc
checkSideConditions dflags mtheta cls cls_tys tc rep_tc
| Just cond <- sideConditions mtheta cls
= case (cond dflags rep_tc) of
= case (cond dflags tc rep_tc) of
NotValid err -> DerivableClassError err -- Class-specific error
IsValid | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-> CanDerive
......@@ -497,38 +497,87 @@ canDeriveAnyClass dflags
| otherwise
= IsValid -- OK!
type Condition = DynFlags -> TyCon -> Validity
-- TyCon is the *representation* tycon if the data type is an indexed one
-- Nothing => OK
type Condition
= DynFlags
-> TyCon -- ^ The data type's 'TyCon'. For data families, this is the
-- family 'TyCon'.
-> TyCon -- ^ For data families, this is the representation 'TyCon'.
-- Otherwise, this is the same as the other 'TyCon' argument.
-> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
-- possible. Otherwise, it's @'NotValid' err@, where @err@
-- explains what went wrong.
orCond :: Condition -> Condition -> Condition
orCond c1 c2 dflags tc
= case (c1 dflags tc, c2 dflags tc) of
orCond c1 c2 dflags tc rep_tc
= case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of
(IsValid, _) -> IsValid -- c1 succeeds
(_, IsValid) -> IsValid -- c21 succeeds
(NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition
andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc
cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
-- if standalone, we just say "yes, go for it"
-> Bool -- True <=> permissive: allow higher rank
-- args and no data constructors
-> Condition
cond_stdOK (Just _) _ _ _
= IsValid -- Don't check these conservative conditions for
andCond c1 c2 dflags tc rep_tc
= c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc
-- | Some common validity checks shared among stock derivable classes. One
-- check that absolutely must hold is that if an instance @C (T a)@ is being
-- derived, then @T@ must be a tycon for a data type or a newtype. The
-- remaining checks are only performed if using a @deriving@ clause (i.e.,
-- they're ignored if using @StandaloneDeriving@):
--
-- 1. The data type must have at least one constructor (this check is ignored
-- if using @EmptyDataDeriving@).
--
-- 2. The data type cannot have any GADT constructors.
--
-- 3. The data type cannot have any constructors with existentially quantified
-- type variables.
--
-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
--
-- 5. The data type cannot have fields with higher-rank types.
cond_stdOK
:: DerivContext -- ^ 'Just' if this is standalone deriving, 'Nothing' if not.
-- If it is standalone, we relax some of the validity checks
-- we would otherwise perform (i.e., "just go for it").
-> Bool -- ^ 'True' <=> allow higher rank arguments and empty data
-- types (with no data constructors) even in the absence of
-- the -XEmptyDataDeriving extension.
-> Condition
cond_stdOK mtheta permissive dflags tc rep_tc
= valid_ADT `andValid` valid_misc
where
valid_ADT, valid_misc :: Validity
valid_ADT
| isAlgTyCon tc || isDataFamilyTyCon tc
= IsValid
| otherwise
-- Complain about functions, primitive types, and other tycons that
-- stock deriving can't handle.
= NotValid $ text "The last argument of the instance must be a"
<+> text "data or newtype application"
valid_misc
= case mtheta of
Just _ -> IsValid
-- Don't check these conservative conditions for
-- standalone deriving; just generate the code
-- and let the typechecker handle the result
cond_stdOK Nothing permissive dflags rep_tc
| null data_cons
, not permissive = checkFlag LangExt.EmptyDataDeriving dflags rep_tc
`orValid`
NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
| not (null con_whys) = NotValid (vcat con_whys $$ standalone_suggestion)
| otherwise = IsValid
where
Nothing
| null data_cons -- 1.
, not permissive
-> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
| not (null con_whys)
-> NotValid (vcat con_whys $$ standalone_suggestion)
| otherwise
-> IsValid
empty_data_suggestion =
text "Use EmptyDataDeriving to enable deriving for empty data types"
standalone_suggestion =
......@@ -538,13 +587,13 @@ cond_stdOK Nothing permissive dflags rep_tc
check_con :: DataCon -> Validity
check_con con
| not (null eq_spec)
| not (null eq_spec) -- 2.
= bad "is a GADT"
| not (null ex_tvs)
| not (null ex_tvs) -- 3.
= bad "has existential type variables in its type"
| not (null theta)
| not (null theta) -- 4.
= bad "has constraints in its type"
| not (permissive || all isTauTy (dataConOrigArgTys con))
| not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5.
= bad "has a higher-rank type"
| otherwise
= IsValid
......@@ -557,10 +606,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
text "must have at least one data constructor"
cond_RepresentableOk :: Condition
cond_RepresentableOk _ tc = canDoGenerics tc
cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc
cond_Representable1Ok :: Condition
cond_Representable1Ok _ tc = canDoGenerics1 tc
cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc
cond_enumOrProduct :: Class -> Condition
cond_enumOrProduct cls = cond_isEnumeration `orCond`
......@@ -569,13 +618,13 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
cond_args :: Class -> Condition
-- For some classes (eg Eq, Ord) we allow unlifted arg types
-- by generating specialised code. For others (eg Data) we don't.
cond_args cls _ tc
cond_args cls _ _ rep_tc
= case bad_args of
[] -> IsValid
(ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
2 (text "for type" <+> quotes (ppr ty)))
where
bad_args = [ arg_ty | con <- tyConDataCons tc
bad_args = [ arg_ty | con <- tyConDataCons rep_tc
, arg_ty <- dataConOrigArgTys con
, isUnliftedType arg_ty
, not (ok_ty arg_ty) ]
......@@ -593,7 +642,7 @@ cond_args cls _ tc
cond_isEnumeration :: Condition
cond_isEnumeration _ rep_tc
cond_isEnumeration _ _ rep_tc
| isEnumerationTyCon rep_tc = IsValid
| otherwise = NotValid why
where
......@@ -603,7 +652,7 @@ cond_isEnumeration _ rep_tc
-- See Note [Enumeration types] in TyCon
cond_isProduct :: Condition
cond_isProduct _ rep_tc
cond_isProduct _ _ rep_tc
| isProductTyCon rep_tc = IsValid
| otherwise = NotValid why
where
......@@ -617,7 +666,7 @@ cond_functorOK :: Bool -> Bool -> Condition
-- (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
-- (d) optionally: don't use function types
-- (e) no "stupid context" on data type
cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc
| null tc_tvs
= NotValid (text "Data type" <+> quotes (ppr rep_tc)
<+> text "must have some type parameters")
......@@ -666,7 +715,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
wrong_arg = text "must use the type variable only as the last argument of a data type"
checkFlag :: LangExt.Extension -> Condition
checkFlag flag dflags _
checkFlag flag dflags _ _
| xopt flag dflags = IsValid
| otherwise = NotValid why
where
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE StandaloneDeriving #-}
module T13154a where
import GHC.Exts
class C1 a
deriving instance C1 (a -> b)
class C2 (a :: TYPE 'IntRep)
deriving instance C2 Int#
......@@ -85,6 +85,7 @@ test('T12594', normal, compile, [''])
test('T12616', normal, compile, [''])
test('T12688', normal, compile, [''])
test('T12814', normal, compile, ['-Wredundant-constraints'])
test('T13154a', normal, compile, [''])
test('T13272', normal, compile, [''])
test('T13272a', normal, compile, [''])
test('T13297', normal, compile, [''])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment