Commit d5a4e49d authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Make error when deriving an instance for a typeclass less misleading

Before, when you attempted to derive an instance for a typeclass,
e.g.,

```
class C1 (a :: Constraint) where
class C2 where

deriving instance C1 C2
```

GHC would complain that `C2`'s data constructors aren't in scope. But
that
makes no sense, since typeclasses don't have constructors! By refining
the
checks that GHC performs when deriving, we can make the error message a
little more sensible.

This also cleans up a related `DeriveAnyClass` infelicity. Before, you
wouldn't have been able to compile code like this:

```
import System.IO (Handle)
class C a
deriving instance C Handle
```

Since GHC was requiring that all data constructors of `Handle` be in
scope. But `DeriveAnyClass` doesn't even generate code that mentions
any data constructors, so this requirement is silly!

Fixes #11509.

Test Plan: make test TEST=T11509

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D2558

GHC Trac Issues: #11509
parent 8c6a3d68
......@@ -764,19 +764,6 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
; when (isDataFamilyTyCon rep_tc)
(bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
-- For standalone deriving (mtheta /= Nothing),
-- check that all the data constructors are in scope.
; rdr_env <- getGlobalRdrEnv
; let data_con_names = map dataConName (tyConDataCons rep_tc)
hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
(isAbstractTyCon rep_tc ||
any not_in_scope data_con_names)
not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc)
; addUsedDataCons rdr_env rep_tc
; unless (isNothing mtheta || not hidden_data_cons)
(bale_out (derivingHiddenErr tycon))
; dflags <- getDynFlags
; if isDataTyCon rep_tc then
mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
......@@ -881,22 +868,27 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
Just DerivNewtype -> bale_out gndNonNewtypeErr
-- Lacking a user-requested deriving strategy, we will try to pick
-- between the stock or anyclass strategies
Nothing -> mk_eqn_no_mechanism dflags mtheta cls cls_tys rep_tc
Nothing -> mk_eqn_no_mechanism dflags tycon mtheta cls cls_tys rep_tc
go_for_it bale_out
where
go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
go_for_it = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args
rep_tc rep_tc_args mtheta (isJust deriv_strat)
bale_out msg = failWithTc (derivingThingErr False cls cls_tys
(mkTyConApp tycon tc_args) deriv_strat msg)
mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
-> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
-> Bool -- True if an explicit deriving strategy keyword was
-- provided
-> DerivSpecMechanism -- How GHC should proceed attempting to
-- derive this instance, determined in
-- mkDataTypeEqn/mkNewTypeEqn
-> TcM EarlyDerivSpec
mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
mtheta mechanism
= do loc <- getSrcSpanM
mtheta strat_used mechanism
= do doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tc mtheta
strat_used mechanism
loc <- getSrcSpanM
dfun_name <- newDFunName' cls tycon
case mtheta of
Nothing -> -- Infer context
......@@ -951,17 +943,27 @@ mk_eqn_anyclass dflags rep_tc cls go_for_it bale_out
Nothing -> go_for_it DerivSpecAnyClass
Just msg -> bale_out msg
mk_eqn_no_mechanism :: DynFlags -> DerivContext -> Class -> [Type] -> TyCon
mk_eqn_no_mechanism :: DynFlags -> TyCon -> DerivContext
-> Class -> [Type] -> TyCon
-> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
-> (SDoc -> TcRn EarlyDerivSpec)
-> TcRn EarlyDerivSpec
mk_eqn_no_mechanism dflags mtheta cls cls_tys rep_tc go_for_it bale_out
mk_eqn_no_mechanism dflags tc mtheta cls cls_tys rep_tc go_for_it bale_out
= case checkSideConditions dflags mtheta cls cls_tys rep_tc of
-- NB: pass the *representation* tycon to checkSideConditions
NonDerivableClass msg -> bale_out (nonStdErr cls $$ msg)
NonDerivableClass msg -> bale_out (dac_error msg)
DerivableClassError msg -> bale_out msg
CanDerive -> mk_eqn_stock' cls go_for_it
DerivableViaInstance -> go_for_it DerivSpecAnyClass
where
-- See Note [Deriving instances for classes themselves]
dac_error msg
| isClassTyCon rep_tc
= quotes (ppr tc) <+> text "is a type class,"
<+> text "and can only have a derived instance"
$+$ text "if DeriveAnyClass is enabled"
| otherwise
= nonStdErr cls $$ msg
{-
************************************************************************
......@@ -1051,6 +1053,9 @@ mkNewTypeEqn dflags overlap_mode tvs
go_for_it_gnd = do
traceTc "newtype deriving:" $
ppr tycon <+> ppr rep_tys <+> ppr all_preds
let mechanism = DerivSpecNewtype rep_inst_ty
doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tycon mtheta
strat_used mechanism
dfun_name <- newDFunName' cls tycon
loc <- getSrcSpanM
case mtheta of
......@@ -1061,7 +1066,7 @@ mkNewTypeEqn dflags overlap_mode tvs
, ds_tc = rep_tycon
, ds_theta = theta
, ds_overlap = overlap_mode
, ds_mechanism = DerivSpecNewtype rep_inst_ty }
, ds_mechanism = mechanism }
Nothing -> return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = dfun_tvs
......@@ -1069,13 +1074,14 @@ mkNewTypeEqn dflags overlap_mode tvs
, ds_tc = rep_tycon
, ds_theta = all_preds
, ds_overlap = overlap_mode
, ds_mechanism = DerivSpecNewtype rep_inst_ty }
, ds_mechanism = mechanism }
go_for_it_other = mk_data_eqn overlap_mode tvs cls cls_tys tycon
tc_args rep_tycon rep_tc_args mtheta
tc_args rep_tycon rep_tc_args mtheta strat_used
bale_out = bale_out' newtype_deriving
bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
deriv_strat
strat_used = isJust deriv_strat
non_std = nonStdErr cls
suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension"
......@@ -1312,7 +1318,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
-- See Note [Bindings for Generalised Newtype Deriving]
| DerivSpecNewtype rhs_ty <- mechanism
= do { inst_spec <- newDerivClsInst theta spec
; doDerivInstErrorChecks clas inst_spec mechanism
; doDerivInstErrorChecks2 clas inst_spec mechanism
; return ( InstInfo
{ iSpec = inst_spec
, iBinds = InstBindings
......@@ -1333,7 +1339,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
= do { (meth_binds, deriv_stuff) <- genDerivStuff mechanism loc clas
rep_tycon tys tvs
; inst_spec <- newDerivClsInst theta spec
; doDerivInstErrorChecks clas inst_spec mechanism
; doDerivInstErrorChecks2 clas inst_spec mechanism
; traceTc "newder" (ppr inst_spec)
; let inst_info
= InstInfo { iSpec = inst_spec
......@@ -1345,9 +1351,35 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
, ib_derived = True } }
; return ( inst_info, deriv_stuff, Nothing ) }
doDerivInstErrorChecks :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks clas clas_inst mechanism
= do { traceTc "doDerivInstErrorChecks" (ppr clas_inst)
doDerivInstErrorChecks1 :: Class -> [Type] -> TyCon -> [Type] -> TyCon
-> DerivContext -> Bool -> DerivSpecMechanism
-> TcM ()
doDerivInstErrorChecks1 cls cls_tys tc tc_args rep_tc mtheta
strat_used mechanism = do
-- For standalone deriving (mtheta /= Nothing),
-- check that all the data constructors are in scope...
rdr_env <- getGlobalRdrEnv
let data_con_names = map dataConName (tyConDataCons rep_tc)
hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
(isAbstractTyCon rep_tc ||
any not_in_scope data_con_names)
not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc)
addUsedDataCons rdr_env rep_tc
-- ...however, we don't perform this check if we're using DeriveAnyClass,
-- since it doesn't generate any code that requires use of a data
-- constructor.
unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $
bale_out $ derivingHiddenErr tc
where
anyclass_strategy = isDerivSpecAnyClass mechanism
bale_out msg = failWithTc (derivingThingErrMechanism cls cls_tys
(mkTyConApp tc tc_args) strat_used mechanism msg)
doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 clas clas_inst mechanism
= do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
; dflags <- getDynFlags
-- Check for Generic instances that are derived with an exotic
-- deriving strategy like DAC
......@@ -1490,6 +1522,25 @@ GHC will use to derive the instance after taking the above steps. In other
words, GHC will always settle on a DerivSpecMechnism, even if the user did not
ask for a particular DerivStrategy (using the algorithm linked to above).
Note [Deriving instances for classes themselves]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Much of the code in TcDeriv assumes that deriving only works on data types.
But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
reasonable to do something like this:
{-# LANGUAGE DeriveAnyClass #-}
class C1 (a :: Constraint) where
class C2 where
deriving instance C1 C2
-- This is equivalent to `instance C1 C2`
If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
deriving), we throw a special error message indicating that DeriveAnyClass is
the only way to go. We don't bother throwing this error if an explicit 'stock'
or 'newtype' keyword is used, since both options have their own perfectly
sensible error messages in the case of the above code (as C1 isn't a stock
derivable class, and C2 isn't a newtype).
************************************************************************
* *
\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
......@@ -1537,19 +1588,34 @@ derivingEtaErr cls cls_tys inst_ty
derivingThingErr :: Bool -> Class -> [Type] -> Type -> Maybe DerivStrategy
-> MsgDoc -> MsgDoc
derivingThingErr newtype_deriving clas tys ty deriv_strat why
= derivingThingErr' newtype_deriving clas tys ty (isJust deriv_strat)
(maybe empty ppr deriv_strat) why
derivingThingErrMechanism :: Class -> [Type] -> Type
-> Bool -- True if an explicit deriving strategy
-- keyword was provided
-> DerivSpecMechanism
-> MsgDoc -> MsgDoc
derivingThingErrMechanism clas tys ty strat_used mechanism why
= derivingThingErr' (isDerivSpecNewtype mechanism) clas tys ty strat_used
(ppr mechanism) why
derivingThingErr' :: Bool -> Class -> [Type] -> Type -> Bool -> MsgDoc
-> MsgDoc -> MsgDoc
derivingThingErr' newtype_deriving clas tys ty strat_used strat_msg why
= sep [(hang (text "Can't make a derived instance of")
2 (quotes (ppr pred) <+> via_mechanism)
$$ nest 2 extra) <> colon,
nest 2 why]
where
extra | Nothing <- deriv_strat, newtype_deriving
extra | not strat_used, newtype_deriving
= text "(even with cunning GeneralizedNewtypeDeriving)"
| otherwise = Outputable.empty
| otherwise = empty
pred = mkClassPred clas (tys ++ [ty])
via_mechanism = case deriv_strat of
Just strat -> text "with the" <+> ppr strat
<+> text "strategy"
Nothing -> empty
via_mechanism | strat_used
= text "with the" <+> strat_msg <+> text "strategy"
| otherwise
= empty
derivingHiddenErr :: TyCon -> SDoc
derivingHiddenErr tc
......
......@@ -9,7 +9,9 @@ Error-checking and other utilities for @deriving@ clauses or declarations.
{-# LANGUAGE ImplicitParams #-}
module TcDerivUtils (
DerivSpec(..), pprDerivSpec, DerivSpecMechanism(..),
DerivSpec(..), pprDerivSpec,
DerivSpecMechanism(..), isDerivSpecStock,
isDerivSpecNewtype, isDerivSpecAnyClass,
DerivContext, DerivStatus(..),
PredOrigin(..), ThetaOrigin, mkPredOrigin,
mkThetaOrigin, substPredOrigin, substThetaOrigin,
......@@ -87,15 +89,16 @@ Example:
-}
pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
ds_cls = c, ds_tys = tys, ds_theta = rhs })
pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
ds_tys = tys, ds_theta = rhs, ds_mechanism = mech })
= hang (text "DerivSpec")
2 (vcat [ text "ds_loc =" <+> ppr l
, text "ds_name =" <+> ppr n
, text "ds_tvs =" <+> ppr tvs
, text "ds_cls =" <+> ppr c
, text "ds_tys =" <+> ppr tys
, text "ds_theta =" <+> ppr rhs ])
2 (vcat [ text "ds_loc =" <+> ppr l
, text "ds_name =" <+> ppr n
, text "ds_tvs =" <+> ppr tvs
, text "ds_cls =" <+> ppr c
, text "ds_tys =" <+> ppr tys
, text "ds_theta =" <+> ppr rhs
, text "ds_mechanism =" <+> ppr mech ])
instance Outputable theta => Outputable (DerivSpec theta) where
ppr = pprDerivSpec
......@@ -112,6 +115,26 @@ data DerivSpecMechanism
| DerivSpecAnyClass -- -XDeriveAnyClass
isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass
:: DerivSpecMechanism -> Bool
isDerivSpecStock (DerivSpecStock{}) = True
isDerivSpecStock _ = False
isDerivSpecNewtype (DerivSpecNewtype{}) = True
isDerivSpecNewtype _ = False
isDerivSpecAnyClass (DerivSpecAnyClass{}) = True
isDerivSpecAnyClass _ = False
-- A DerivSpecMechanism can be losslessly converted to a DerivStrategy.
mechanismToStrategy :: DerivSpecMechanism -> DerivStrategy
mechanismToStrategy (DerivSpecStock{}) = DerivStock
mechanismToStrategy (DerivSpecNewtype{}) = DerivNewtype
mechanismToStrategy (DerivSpecAnyClass{}) = DerivAnyclass
instance Outputable DerivSpecMechanism where
ppr = ppr . mechanismToStrategy
type DerivContext = Maybe ThetaType
-- Nothing <=> Vanilla deriving; infer the context of the instance decl
-- Just theta <=> Standalone deriving: context supplied by programmer
......
......@@ -42,6 +42,20 @@ Compiler
class instance using the :ghc-flag:`-XDerivingStrategies` language extension
(see :ref:`deriving-strategies`).
- GHC now allows standalone deriving using :ghc-flag:`-XDeriveAnyClass` on
any data type, even if its data constructors are not in scope. This is
consistent with the fact that this code (in the presence of
:ghc-flag:`-XDeriveAnyClass`): ::
deriving instance C T
is exactly equivalent to: ::
instance C T
and the latter code has no restrictions about whether the data constructors
of ``T`` are in scope.
GHCi
~~~~
......@@ -159,7 +173,7 @@ filepath
ghc
~~~
-
-
ghc-boot
~~~~~~~~
......
......@@ -3267,6 +3267,17 @@ number of important ways:
necessarily more conservative, but any error message may be more
comprehensible.
- Under most circumstances, you cannot use standalone deriving to create an
instance for a data type whose constructors are not all in scope. This is
because the derived instance would generate code that uses the constructors
behind the scenes, which would break abstraction.
The one exception to this rule is :ghc-flag:`-XDeriveAnyClass`, since
deriving an instance via :ghc-flag:`-XDeriveAnyClass` simply generates
an empty instance declaration, which does not require the use of any
constructors. See the `deriving any class <#derive-any-class>`__ section
for more details.
In other ways, however, a standalone deriving obeys the same rules as
ordinary deriving:
......
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
module T11509_2 where
import GHC.Exts (Constraint)
class C1 (a :: Constraint) where
class C2 where
deriving instance C1 C2
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
module T11509_3 where
import System.IO (Handle) -- A data type whose constructors are hidden
class C a where
deriving instance C Handle
......@@ -66,6 +66,8 @@ test('T11174', normal, compile, [''])
test('T11416', normal, compile, [''])
test('T11396', normal, compile, [''])
test('T11357', normal, compile, [''])
test('T11509_2', expect_fail, compile, [''])
test('T11509_3', normal, compile, [''])
test('T11732a', normal, compile, [''])
test('T11732b', normal, compile, [''])
test('T11732c', normal, compile, [''])
......
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StaticPointers #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module T11509 where
import Data.Kind
import Data.Typeable
import GHC.StaticPtr
{-------------------------------------------------------------------------------
Standard Cloud-Haskell-like infrastructure
See <https://ghc.haskell.org/trac/ghc/wiki/TypeableT> for a dicussion of 'SC'.
-------------------------------------------------------------------------------}
class Serializable a -- empty class, just for demonstration purposes
instance Serializable a => Serializable [a]
data Static :: * -> * where
StaticPtr :: StaticPtr a -> Static a
StaticApp :: Static (a -> b) -> Static a -> Static b
staticApp :: StaticPtr (a -> b) -> Static a -> Static b
staticApp = StaticApp . StaticPtr
data Dict :: Constraint -> * where
Dict :: c => Dict c
class c => SC c where
dict :: Static (Dict c)
instance (Typeable a, SC (Serializable a)) => SC (Serializable [a]) where
dict = aux `staticApp` dict
where
aux :: StaticPtr (Dict (Serializable a) -> Dict (Serializable [a]))
aux = static (\Dict -> Dict)
{-------------------------------------------------------------------------------
Demonstrate the bug
-------------------------------------------------------------------------------}
newtype MyList a = MyList [a]
deriving instance (Typeable a, SC (Serializable a)) => SC (Serializable (MyList a))
T11509_1.hs:52:1: error:
• Can't make a derived instance of ‘SC (Serializable (MyList a))’:
‘Serializable’ is a type class, and can only have a derived instance
if DeriveAnyClass is enabled
• In the stand-alone deriving instance for
‘(Typeable a, SC (Serializable a)) => SC (Serializable (MyList a))’
......@@ -64,5 +64,7 @@ test('T10598_fail3', normal, compile_fail, [''])
test('T10598_fail4', normal, compile_fail, [''])
test('T10598_fail5', normal, compile_fail, [''])
test('T10598_fail6', normal, compile_fail, [''])
test('T11509_1', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
compile_fail, [''])
test('T12163', normal, compile_fail, [''])
test('T12512', omit_ways(['ghci']), compile_fail, [''])
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