Commit cd9b9459 authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Refactor TcDeriv to validity-check less in anyclass/via deriving (#13154)

Due to the way `DerivEnv` is currently structured, there is an
invariant that every derived instance must consist of a class applied
to a non-empty list of argument types, where the last argument *must*
be an application of a type constructor to some arguments. This works
for many cases, but there are also some design patterns in standalone
`anyclass`/`via` deriving that are made impossible due to enforcing
this invariant, as documented in #13154.

This fixes #13154 by refactoring `TcDeriv` and friends to perform
fewer validity checks when using the `anyclass` or `via` strategies.
The highlights are as followed:

* Five fields of `DerivEnv` have been factored out into a new
  `DerivInstTys` data type. These fields only make sense for
  instances that satisfy the invariant mentioned above, so
  `DerivInstTys` is now only used in `stock` and `newtype` deriving,
  but not in other deriving strategies.
* There is now a `Note [DerivEnv and DerivSpecMechanism]` describing
  the bullet point above in more detail, as well as explaining the
  exact requirements that each deriving strategy imposes.
* I've refactored `mkEqnHelp`'s call graph to be slightly less
  complicated. Instead of the previous `mkDataTypeEqn`/`mkNewTypeEqn`
  dichotomy, there is now a single entrypoint `mk_eqn`.
* Various bits of code were tweaked so as not to use fields that are
  specific to `DerivInstTys` so that they may be used by all deriving
  strategies, since not all deriving strategies use `DerivInstTys`.
parent 6635a3f6
Pipeline #11910 passed with stages
in 943 minutes and 18 seconds
This diff is collapsed.
......@@ -73,22 +73,25 @@ inferConstraints :: DerivSpecMechanism
-- before being used in the instance declaration
inferConstraints mechanism
= do { DerivEnv { denv_tvs = tvs
, denv_tc = tc
, denv_tc_args = tc_args
, denv_cls = main_cls
, denv_cls_tys = cls_tys } <- ask
, denv_inst_tys = inst_tys } <- ask
; wildcard <- isStandaloneWildcardDeriv
; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])
infer_constraints =
case mechanism of
DerivSpecStock{}
-> inferConstraintsStock
DerivSpecStock{dsm_stock_dit = dit}
-> inferConstraintsStock dit
DerivSpecAnyClass
-> infer_constraints_simple $ inferConstraintsAnyclass
DerivSpecNewtype rep_ty
-> infer_constraints_simple $ inferConstraintsCoerceBased rep_ty
DerivSpecVia via_ty
-> infer_constraints_simple $ inferConstraintsCoerceBased via_ty
-> infer_constraints_simple inferConstraintsAnyclass
DerivSpecNewtype { dsm_newtype_dit =
DerivInstTys{dit_cls_tys = cls_tys}
, dsm_newtype_rep_ty = rep_ty }
-> infer_constraints_simple $
inferConstraintsCoerceBased cls_tys rep_ty
DerivSpecVia { dsm_via_cls_tys = cls_tys
, dsm_via_ty = via_ty }
-> infer_constraints_simple $
inferConstraintsCoerceBased cls_tys via_ty
-- Most deriving strategies do not need to do anything special to
-- the type variables and arguments to the class in the derived
......@@ -102,9 +105,6 @@ inferConstraints mechanism
thetas <- infer_thetas
pure (thetas, tvs, inst_tys)
inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
-- Constraints arising from superclasses
-- See Note [Superclasses of derived instance]
cls_tvs = classTyVars main_cls
......@@ -147,20 +147,19 @@ inferConstraints mechanism
-- to be well kinded, so we return @[]@/@[Type, f, g]@ for the
-- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@.
-- See Note [Inferring the instance context].
inferConstraintsStock :: DerivM ([ThetaOrigin], [TyVar], [TcType])
inferConstraintsStock
inferConstraintsStock :: DerivInstTys
-> DerivM ([ThetaOrigin], [TyVar], [TcType])
inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys
, dit_tc = tc
, dit_tc_args = tc_args
, dit_rep_tc = rep_tc
, dit_rep_tc_args = rep_tc_args })
= do DerivEnv { denv_tvs = tvs
, denv_tc = tc
, denv_tc_args = tc_args
, denv_rep_tc = rep_tc
, denv_rep_tc_args = rep_tc_args
, denv_cls = main_cls
, denv_cls_tys = cls_tys } <- ask
, denv_inst_tys = inst_tys } <- ask
wildcard <- isStandaloneWildcardDeriv
let inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
tc_binders = tyConBinders rep_tc
choose_level bndr
| isNamedTyConBinder bndr = KindLevel
......@@ -339,16 +338,11 @@ inferConstraintsStock
-- derived instance context.
inferConstraintsAnyclass :: DerivM [ThetaOrigin]
inferConstraintsAnyclass
= do { DerivEnv { denv_tc = tc
, denv_tc_args = tc_args
, denv_cls = cls
, denv_cls_tys = cls_tys } <- ask
= do { DerivEnv { denv_cls = cls
, denv_inst_tys = inst_tys } <- ask
; wildcard <- isStandaloneWildcardDeriv
; let inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
gen_dms = [ (sel_id, dm_ty)
; let gen_dms = [ (sel_id, dm_ty)
| (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
cls_tvs = classTyVars cls
......@@ -384,13 +378,12 @@ inferConstraintsAnyclass
-- We would infer the following constraints ('ThetaOrigin's):
--
-- > (Num Int, Coercible Age Int)
inferConstraintsCoerceBased :: Type -> DerivM [ThetaOrigin]
inferConstraintsCoerceBased rep_ty = do
inferConstraintsCoerceBased :: [Type] -> Type
-> DerivM [ThetaOrigin]
inferConstraintsCoerceBased cls_tys rep_ty = do
DerivEnv { denv_tvs = tvs
, denv_tc = tycon
, denv_tc_args = tc_args
, denv_cls = cls
, denv_cls_tys = cls_tys } <- ask
, denv_inst_tys = inst_tys } <- ask
sa_wildcard <- isStandaloneWildcardDeriv
let -- The following functions are polymorphic over the representation
-- type, since we might either give it the underlying type of a
......@@ -402,8 +395,6 @@ inferConstraintsCoerceBased rep_ty = do
-- rep_pred is the representation dictionary, from where
-- we are going to get all the methods for the final
-- dictionary
inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty]
deriv_origin = mkDerivOrigin sa_wildcard
-- Next we collect constraints for the class methods
......
This diff is collapsed.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module T13154b where
import Data.Kind
import Data.Typeable
import GHC.Exts
import GHC.TypeLits
class Foo1 (a :: TYPE ('TupleRep '[]))
deriving instance Foo1 a
class Foo2 (a :: TYPE ('TupleRep '[]))
deriving instance Foo2 (##)
class Foo3 (a :: TYPE ('SumRep '[ 'LiftedRep, 'LiftedRep ]))
deriving instance Foo3 a
class Foo4 (a :: TYPE ('SumRep '[ 'LiftedRep, 'LiftedRep ]))
deriving instance Foo4 (# a | b #)
class Foo5 (a :: Type)
deriving instance Foo5 a
class Foo6
deriving instance Foo6
class Foo7 (a :: Nat)
deriving anyclass instance Foo7 0
deriving instance Foo7 1
class Foo8 (a :: Symbol)
deriving anyclass instance Foo8 "a"
deriving instance Foo8 "b"
class Typeable a => Foo9 a
deriving instance _ => Foo9 (f a)
data family D1 a
newtype ByBar a = ByBar a
class Foo10 a where
baz :: a -> a
instance Foo10 (ByBar a) where
baz = id
deriving via ByBar (D1 a) instance Foo10 (D1 a)
data family D2
data family D3
class Foo11 a where
deriving anyclass instance Foo11 D2
deriving instance Foo11 D3
......@@ -89,6 +89,7 @@ test('T12616', normal, compile, [''])
test('T12688', normal, compile, [''])
test('T12814', normal, compile, ['-Wredundant-constraints'])
test('T13154a', normal, compile, [''])
test('T13154b', normal, compile, [''])
test('T13272', normal, compile, [''])
test('T13272a', normal, compile, [''])
test('T13297', normal, compile, [''])
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UnboxedTuples #-}
module T13154c where
import GHC.Exts
-- Test some nonsense configurations
class Foo1 (a :: TYPE ('TupleRep '[]))
deriving stock instance Foo1 a
deriving stock instance Foo1 (##)
deriving newtype instance Foo1 a
deriving newtype instance Foo1 (##)
class Foo2
deriving stock instance Foo2
deriving newtype instance Foo2
T13154c.hs:16:1: error:
• Can't make a derived instance of
‘Foo1 a’ with the stock strategy:
The last argument of the instance must be a data or newtype application
• In the stand-alone deriving instance for ‘Foo1 a’
T13154c.hs:17:1: error:
• Can't make a derived instance of
‘Foo1 (# #)’ with the stock strategy:
‘Foo1’ is not a stock derivable class (Eq, Show, etc.)
• In the stand-alone deriving instance for ‘Foo1 (# #)’
T13154c.hs:18:1: error:
• Can't make a derived instance of
‘Foo1 a’ with the newtype strategy:
The last argument of the instance must be a data or newtype application
• In the stand-alone deriving instance for ‘Foo1 a’
T13154c.hs:19:1: error:
• Can't make a derived instance of
‘Foo1 (# #)’ with the newtype strategy:
GeneralizedNewtypeDeriving cannot be used on non-newtypes
• In the stand-alone deriving instance for ‘Foo1 (# #)’
T13154c.hs:22:1: error:
• Can't make a derived instance of ‘Foo2’ with the stock strategy:
Cannot derive instances for nullary classes
• In the stand-alone deriving instance for ‘Foo2’
T13154c.hs:23:1: error:
• Can't make a derived instance of
‘Foo2’ with the newtype strategy:
Cannot derive instances for nullary classes
• In the stand-alone deriving instance for ‘Foo2’
T7959.hs:5:1: error:
• Cannot derive instances for nullary classes
• Can't make a derived instance of ‘A’: Try enabling DeriveAnyClass
• In the stand-alone deriving instance for ‘A’
T7959.hs:6:17: error:
......
......@@ -66,6 +66,7 @@ test('T11509_1', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
test('T12163', normal, compile_fail, [''])
test('T12512', omit_ways(['ghci']), compile_fail, [''])
test('T12801', normal, compile_fail, [''])
test('T13154c', normal, compile_fail, [''])
test('T14365', [extra_files(['T14365B.hs','T14365B.hs-boot'])],
multimod_compile_fail, ['T14365A',''])
test('T14728a', normal, 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