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

Refactor some cruft in TcDerivInfer.inferConstraints

The latest installment in my quest to clean up the code in
`TcDeriv*`. This time, my sights are set on
`TcDerivInfer.inferConstraints`, which infers the context for derived
instances. This function is a wee bit awkward at the moment:

* It's not terribly obvious from a quick glance, but
  `inferConstraints` is only ever invoked when using the `stock` or
  `anyclass` deriving strategies, as the code for inferring the
  context for `newtype`- or `via`-derived instances is located
  separately in `mk_coerce_based_eqn`. But there's no good reason
  for things to be this way, so I moved this code from
  `mk_coerce_based_eqn` to `inferConstraints` so that everything
  related to inferring instance contexts is located in one place.
* In this process, I discovered that the Haddocks for the auxiliary
  function `inferConstraintsDataConArgs` are completely wrong. It
  claims that it handles both `stock` and `newtype` deriving, but
  this is completely wrong, as discussed above—it only handles
  `stock`. To rectify this, I renamed this function to
  `inferConstraintsStock` to reflect its actual purpose and created
  a new `inferConstraintsCoerceBased` function to specifically
  handle `newtype` (and `via`) deriving.

Doing this revealed some opportunities for further simplification:

* Removing the context-inference–related code from
  `mk_coerce_based_eqn` made me realize that the overall structure
  of the function is basically identical to `mk_originative_eqn`.
  In fact, I was easily able to combine the two functions into a
  single `mk_eqn_from_mechanism` function.

  As part of this merger, I now invoke
  `atf_coerce_based_error_checks` from `doDerivInstErrorChecks1`.
* I discovered that GHC defined this function:

  ```hs
  typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
  ```

  No fewer than four times in different modules. I consolidated all
  of these definitions in a single location in `TysWiredIn`.
parent 0ca044fd
Pipeline #11373 passed with stages
in 360 minutes and 43 seconds
......@@ -92,7 +92,8 @@ module TysWiredIn (
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
isLiftedTypeKindTyConName, liftedTypeKind,
typeToTypeKind, constraintKind,
liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,
liftedTypeKindTyConName,
......@@ -612,8 +613,9 @@ typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, constraintKind :: Kind
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind = tYPE liftedRepTy
typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
{-
......
......@@ -60,7 +60,6 @@ import Util
import Outputable
import FastString
import Bag
import Pair
import FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
......@@ -153,31 +152,6 @@ Notice the free 'a' in the deriving. We have to fill this out to
And then translate it to:
instance C [a] Char => C [a] T where ...
Note [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(See also #1220 for an interesting exchange on newtype
deriving and superclasses.)
The 'tys' here come from the partial application in the deriving
clause. The last arg is the new instance type.
We must pass the superclasses; the newtype might be an instance
of them in a different way than the representation type
E.g. newtype Foo a = Foo a deriving( Show, Num, Eq )
Then the Show instance is not done via Coercible; it shows
Foo 3 as "Foo 3"
The Num instance is derived via Coercible, but the Show superclass
dictionary must the Show instance for Foo, *not* the Show dictionary
gotten from the Num dictionary. So we must build a whole new dictionary
not just use the Num one. The instance we want is something like:
instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
(+) = ((+)@a)
...etc...
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2
Note [Unused constructors and deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #3221. Consider
......@@ -1299,15 +1273,10 @@ mkDataTypeEqn
-- between the stock or anyclass strategies
Nothing -> mk_eqn_no_mechanism
-- Derive an instance by way of an originative deriving strategy
-- (stock or anyclass).
--
-- See Note [Deriving strategies]
mk_originative_eqn
:: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or
-- DerivSpecAnyclass
-> DerivM EarlyDerivSpec
mk_originative_eqn mechanism
-- Once the DerivSpecMechanism is known, we can finally produce an
-- EarlyDerivSpec from it.
mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
mk_eqn_from_mechanism mechanism
= do DerivEnv { denv_overlap_mode = overlap_mode
, denv_tvs = tvs
, denv_tc = tc
......@@ -1346,151 +1315,6 @@ mk_originative_eqn mechanism
, ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism }
-- Derive an instance by way of a coerce-based deriving strategy
-- (newtype or via).
--
-- See Note [Deriving strategies]
mk_coerce_based_eqn
:: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype
-- or DerivSpecVia
-> Type -- The type to coerce
-> DerivM EarlyDerivSpec
mk_coerce_based_eqn mk_mechanism coerced_ty
= do DerivEnv { denv_overlap_mode = overlap_mode
, denv_tvs = tvs
, denv_tc = tycon
, denv_tc_args = tc_args
, denv_rep_tc = rep_tycon
, denv_cls = cls
, denv_cls_tys = cls_tys
, denv_ctxt = deriv_ctxt } <- 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
-- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
-- (for DerivingVia).
rep_tys ty = cls_tys ++ [ty]
rep_pred ty = mkClassPred cls (rep_tys ty)
rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)
-- rep_pred is the representation dictionary, from where
-- we are going to get all the methods for the final
-- dictionary
-- Next we figure out what superclass dictionaries to use
-- See Note [Newtype deriving superclasses] above
sc_preds :: [PredOrigin]
cls_tyvars = classTyVars cls
inst_ty = mkTyConApp tycon tc_args
inst_tys = cls_tys ++ [inst_ty]
sc_preds = map (mkPredOrigin deriv_origin TypeLevel) $
substTheta (zipTvSubst cls_tyvars inst_tys) $
classSCTheta cls
deriv_origin = mkDerivOrigin sa_wildcard
-- Next we collect constraints for the class methods
-- If there are no methods, we don't need any constraints
-- Otherwise we need (C rep_ty), for the representation methods,
-- and constraints to coerce each individual method
meth_preds :: Type -> [PredOrigin]
meths = classMethods cls
meth_preds ty
| null meths = [] -- No methods => no constraints
-- (#12814)
| otherwise = rep_pred_o ty : coercible_constraints ty
coercible_constraints ty
= [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
TypeLevel (mkReprPrimEqPred t1 t2)
| meth <- meths
, let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
inst_tys ty meth ]
all_thetas :: Type -> [ThetaOrigin]
all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds]
inferred_thetas = all_thetas coerced_ty
lift $ traceTc "newtype deriving:" $
ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas
let mechanism = mk_mechanism coerced_ty
atf_coerce_based_error_checks mechanism cls
doDerivInstErrorChecks1 mechanism
loc <- lift getSrcSpanM
dfun_name <- lift $ newDFunName cls inst_tys loc
case deriv_ctxt of
SupplyContext theta -> return $ GivenTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon
, ds_theta = theta
, ds_overlap = overlap_mode
, ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism }
InferContext wildcard -> return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_tc = rep_tycon
, ds_theta = inferred_thetas
, ds_overlap = overlap_mode
, ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism }
-- Ensure that a class's associated type variables are suitable for
-- GeneralizedNewtypeDeriving or DerivingVia.
--
-- See Note [GND and associated type families]
atf_coerce_based_error_checks
:: DerivSpecMechanism
-> Class -> DerivM ()
atf_coerce_based_error_checks mechanism cls
= let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
cls_tyvars = classTyVars cls
ats_look_sensible
= -- Check (a) from Note [GND and associated type families]
no_adfs
-- Check (b) from Note [GND and associated type families]
&& isNothing at_without_last_cls_tv
-- Check (d) from Note [GND and associated type families]
&& isNothing at_last_cls_tv_in_kinds
(adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
no_adfs = null adf_tcs
-- We cannot newtype-derive data family instances
at_without_last_cls_tv
= find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
at_last_cls_tv_in_kinds
= find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
(tyConTyVars tc)
|| at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
at_last_cls_tv_in_kind kind
= last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
at_tcs = classATs cls
last_cls_tv = ASSERT( notNull cls_tyvars )
last cls_tyvars
cant_derive_err
= vcat [ ppUnless no_adfs adfs_msg
, maybe empty at_without_last_cls_tv_msg
at_without_last_cls_tv
, maybe empty at_last_cls_tv_in_kinds_msg
at_last_cls_tv_in_kinds
]
adfs_msg = text "the class has associated data types"
at_without_last_cls_tv_msg at_tc = hang
(text "the associated type" <+> quotes (ppr at_tc)
<+> text "is not parameterized over the last type variable")
2 (text "of the class" <+> quotes (ppr cls))
at_last_cls_tv_in_kinds_msg at_tc = hang
(text "the associated type" <+> quotes (ppr at_tc)
<+> text "contains the last type variable")
2 (text "of the class" <+> quotes (ppr cls)
<+> text "in a kind, which is not (yet) allowed")
in unless ats_look_sensible $ bale_out cant_derive_err
mk_eqn_stock :: DerivM EarlyDerivSpec
mk_eqn_stock
= do DerivEnv { denv_tc = tc
......@@ -1501,7 +1325,7 @@ mk_eqn_stock
dflags <- getDynFlags
case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
tc rep_tc of
CanDeriveStock gen_fn -> mk_originative_eqn $ DerivSpecStock gen_fn
CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn
StockClassError msg -> derivingThingFailWith False msg
_ -> derivingThingFailWith False (nonStdErr cls)
......@@ -1509,16 +1333,16 @@ mk_eqn_anyclass :: DerivM EarlyDerivSpec
mk_eqn_anyclass
= do dflags <- getDynFlags
case canDeriveAnyClass dflags of
IsValid -> mk_originative_eqn DerivSpecAnyClass
IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass
NotValid msg -> derivingThingFailWith False msg
mk_eqn_newtype :: Type -- The newtype's representation type
-> DerivM EarlyDerivSpec
mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype
mk_eqn_newtype rep_ty = mk_eqn_from_mechanism (DerivSpecNewtype rep_ty)
mk_eqn_via :: Type -- The @via@ type
-> DerivM EarlyDerivSpec
mk_eqn_via = mk_coerce_based_eqn DerivSpecVia
mk_eqn_via via_ty = mk_eqn_from_mechanism (DerivSpecVia via_ty)
mk_eqn_no_mechanism :: DerivM EarlyDerivSpec
mk_eqn_no_mechanism
......@@ -1544,8 +1368,8 @@ mk_eqn_no_mechanism
-- checkOriginativeSideConditions
NonDerivableClass msg -> derivingThingFailWith False (dac_error msg)
StockClassError msg -> derivingThingFailWith False msg
CanDeriveStock gen_fn -> mk_originative_eqn $ DerivSpecStock gen_fn
CanDeriveAnyClass -> mk_originative_eqn DerivSpecAnyClass
CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn
CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass
{-
************************************************************************
......@@ -1717,9 +1541,9 @@ mkNewTypeEqn
, text "Use DerivingStrategies to pick"
<+> text "a different strategy"
]
mk_originative_eqn DerivSpecAnyClass
mk_eqn_from_mechanism DerivSpecAnyClass
-- CanDeriveStock
CanDeriveStock gen_fn -> mk_originative_eqn $
CanDeriveStock gen_fn -> mk_eqn_from_mechanism $
DerivSpecStock gen_fn
{-
......@@ -1972,46 +1796,112 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
set_span_and_ctxt :: TcM a -> TcM a
set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
-- When processing a standalone deriving declaration, check that all of the
-- constructors for the data type are in scope. For instance:
--
-- import M (T)
-- deriving stock instance Eq T
-- Checks:
--
-- This should be rejected, as the derived Eq instance would need to refer to
-- the constructors for T, which are not in scope.
-- * All of the data constructors for a data type are in scope for a
-- standalone-derived instance (for `stock` and `newtype` deriving).
--
-- Note that the only strategies that require this check are `stock` and
-- `newtype`. Neither `anyclass` nor `via` require it as the code that they
-- generate does not require using data constructors.
-- * All of the associated type families of a class are suitable for
-- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via`
-- deriving).
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 mechanism = do
standalone <- isStandaloneDeriv
when standalone $ case mechanism of
DerivSpecStock{} -> check
DerivSpecNewtype{} -> check
doDerivInstErrorChecks1 mechanism =
case mechanism of
DerivSpecStock{} -> data_cons_in_scope_check
DerivSpecNewtype{} -> do atf_coerce_based_error_checks
data_cons_in_scope_check
DerivSpecAnyClass{} -> pure ()
DerivSpecVia{} -> pure ()
DerivSpecVia{} -> atf_coerce_based_error_checks
where
check :: DerivM ()
check = do
DerivEnv { denv_tc = tc, denv_rep_tc = rep_tc } <- ask
-- When processing a standalone deriving declaration, check that all of the
-- constructors for the data type are in scope. For instance:
--
-- import M (T)
-- deriving stock instance Eq T
--
-- This should be rejected, as the derived Eq instance would need to refer
-- to the constructors for T, which are not in scope.
--
-- Note that the only strategies that require this check are `stock` and
-- `newtype`. Neither `anyclass` nor `via` require it as the code that they
-- generate does not require using data constructors.
data_cons_in_scope_check :: DerivM ()
data_cons_in_scope_check = do
standalone <- isStandaloneDeriv
when standalone $ do
DerivEnv { denv_tc = tc, denv_rep_tc = rep_tc } <- ask
let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
rdr_env <- lift 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)
-- Make sure to also mark the data constructors as used so that GHC won't
-- mistakenly emit -Wunused-imports warnings about them.
lift $ addUsedDataCons rdr_env rep_tc
unless (not hidden_data_cons) $
bale_out $ derivingHiddenErr tc
-- Ensure that a class's associated type variables are suitable for
-- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is
-- only required for the `newtype` and `via` strategies.
--
-- See Note [GND and associated type families]
atf_coerce_based_error_checks :: DerivM ()
atf_coerce_based_error_checks = do
cls <- asks denv_cls
let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
rdr_env <- lift 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)
-- Make sure to also mark the data constructors as used so that GHC won't
-- mistakenly emit -Wunused-imports warnings about them.
lift $ addUsedDataCons rdr_env rep_tc
unless (not hidden_data_cons) $
bale_out $ derivingHiddenErr tc
cls_tyvars = classTyVars cls
ats_look_sensible
= -- Check (a) from Note [GND and associated type families]
no_adfs
-- Check (b) from Note [GND and associated type families]
&& isNothing at_without_last_cls_tv
-- Check (d) from Note [GND and associated type families]
&& isNothing at_last_cls_tv_in_kinds
(adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
no_adfs = null adf_tcs
-- We cannot newtype-derive data family instances
at_without_last_cls_tv
= find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
at_last_cls_tv_in_kinds
= find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
(tyConTyVars tc)
|| at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
at_last_cls_tv_in_kind kind
= last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
at_tcs = classATs cls
last_cls_tv = ASSERT( notNull cls_tyvars )
last cls_tyvars
cant_derive_err
= vcat [ ppUnless no_adfs adfs_msg
, maybe empty at_without_last_cls_tv_msg
at_without_last_cls_tv
, maybe empty at_last_cls_tv_in_kinds_msg
at_last_cls_tv_in_kinds
]
adfs_msg = text "the class has associated data types"
at_without_last_cls_tv_msg at_tc = hang
(text "the associated type" <+> quotes (ppr at_tc)
<+> text "is not parameterized over the last type variable")
2 (text "of the class" <+> quotes (ppr cls))
at_last_cls_tv_in_kinds_msg at_tc = hang
(text "the associated type" <+> quotes (ppr at_tc)
<+> text "contains the last type variable")
2 (text "of the class" <+> quotes (ppr cls)
<+> text "in a kind, which is not (yet) allowed")
unless ats_look_sensible $ bale_out cant_derive_err
doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-> DerivSpecMechanism -> TcM ()
......@@ -2184,9 +2074,12 @@ Currently, the deriving strategies are:
The latter two strategies (newtype and via) are referred to as the
"coerce-based" strategies, since they generate code that relies on the `coerce`
function. The former two strategies (stock and anyclass), in contrast, are
function. See, for instance, TcDerivInfer.inferConstraintsCoerceBased.
The former two strategies (stock and anyclass), in contrast, are
referred to as the "originative" strategies, since they create "original"
instances instead of "reusing" old instances (by way of `coerce`).
See, for instance, TcDerivUtils.checkOriginativeSideConditions.
If an explicit deriving strategy is not given, GHC has an algorithm it uses to
determine which strategy it will actually use. The algorithm is quite long,
......
......@@ -22,9 +22,11 @@ import DataCon
import ErrUtils
import Inst
import Outputable
import Pair
import PrelNames
import TcDerivUtils
import TcEnv
import TcGenDeriv
import TcGenFunctor
import TcGenGenerics
import TcMType
......@@ -35,6 +37,7 @@ import Type
import TcSimplify
import TcValidity (validDerivPred)
import TcUnify (buildImplicationFor, checkConstraints)
import TysWiredIn (typeToTypeKind)
import Unify (tcUnifyTy)
import Util
import Var
......@@ -66,15 +69,35 @@ inferConstraints :: DerivSpecMechanism
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
inferConstraints mechanism
= do { DerivEnv { denv_tc = tc
= do { DerivEnv { denv_tvs = tvs
, denv_tc = tc
, denv_tc_args = tc_args
, denv_cls = main_cls
, denv_cls_tys = cls_tys } <- ask
; wildcard <- isStandaloneWildcardDeriv
; let is_anyclass = isDerivSpecAnyClass mechanism
infer_constraints
| is_anyclass = inferConstraintsDAC inst_tys
| otherwise = inferConstraintsDataConArgs inst_ty inst_tys
; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType])
infer_constraints =
case mechanism of
DerivSpecStock{}
-> inferConstraintsStock
DerivSpecAnyClass
-> infer_constraints_simple $ inferConstraintsAnyclass
DerivSpecNewtype rep_ty
-> infer_constraints_simple $ inferConstraintsCoerceBased rep_ty
DerivSpecVia via_ty
-> infer_constraints_simple $ inferConstraintsCoerceBased via_ty
-- Most deriving strategies do not need to do anything special to
-- the type variables and arguments to the class in the derived
-- instance, so they can pass through unchanged. The exception to
-- this rule is stock deriving. See
-- Note [Inferring the instance context].
infer_constraints_simple
:: DerivM [ThetaOrigin]
-> DerivM ([ThetaOrigin], [TyVar], [TcType])
infer_constraints_simple infer_thetas = do
thetas <- infer_thetas
pure (thetas, tvs, inst_tys)
inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
......@@ -98,20 +121,44 @@ inferConstraints mechanism
; return ( sc_constraints ++ inferred_constraints
, tvs', inst_tys' ) }
-- | Like 'inferConstraints', but used only in the case of deriving strategies
-- where the constraints are inferred by inspecting the fields of each data
-- constructor (i.e., stock- and newtype-deriving).
inferConstraintsDataConArgs :: TcType -> [TcType]
-> DerivM ([ThetaOrigin], [TyVar], [TcType])
inferConstraintsDataConArgs inst_ty inst_tys
-- | Like 'inferConstraints', but used only in the case of the @stock@ deriving
-- strategy. The constraints are inferred by inspecting the fields of each data
-- constructor. In this example:
--
-- > data Foo = MkFoo Int Char deriving Show
--
-- We would infer the following constraints ('ThetaOrigin's):
--
-- > (Show Int, Show Char)
--
-- Note that this function also returns the type variables ('TyVar's) and
-- class arguments ('TcType's) for the resulting instance. This is because
-- when deriving 'Functor'-like classes, we must sometimes perform kind
-- substitutions to ensure the resulting instance is well kinded, which may
-- affect the type variables and class arguments. In this example:
--
-- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) =
-- > Compose (f (g a)) deriving stock Functor
--
-- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance
-- 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
= 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
wildcard <- isStandaloneWildcardDeriv
let tc_binders = tyConBinders rep_tc
let inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
tc_binders = tyConBinders rep_tc
choose_level bndr
| isNamedTyConBinder bndr = KindLevel
| otherwise = TypeLevel
......@@ -272,7 +319,7 @@ inferConstraintsDataConArgs inst_ty inst_tys
$$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
do { let (arg_constraints, tvs', inst_tys')
= con_arg_constraints get_std_constrained_tys
; lift $ traceTc "inferConstraintsDataConArgs" $ vcat
; lift $ traceTc "inferConstraintsStock" $ vcat
[ ppr main_cls <+> ppr inst_tys'
, ppr arg_constraints
]
......@@ -280,9 +327,6 @@ inferConstraintsDataConArgs inst_ty inst_tys
++ arg_constraints
, tvs', inst_tys') }
typeToTypeKind :: Kind
typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,
-- which gathers its constraints based on the type signatures of the class's
-- methods instead of the types of the data constructor's field.
......@@ -290,13 +334,18 @@ typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
-- See Note [Gathering and simplifying constraints for DeriveAnyClass]
-- for an explanation of how these constraints are used to determine the
-- derived instance context.
inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
inferConstraintsDAC inst_tys
= do { DerivEnv { denv_tvs = tvs
, denv_cls = cls } <- ask
inferConstraintsAnyclass :: DerivM [ThetaOrigin]
inferConstraintsAnyclass
= do { DerivEnv { denv_tc = tc
, denv_tc_args = tc_args
, denv_cls = cls
, denv_cls_tys = cls_tys } <- ask
; wildcard <- isStandaloneWildcardDeriv
; let gen_dms = [ (sel_id, dm_ty)
; let inst_ty = mkTyConApp tc tc_args
inst_tys = cls_tys ++ [inst_ty]
gen_dms = [ (sel_id, dm_ty)
| (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
cls_tvs = classTyVars cls
......@@ -320,7 +369,61 @@ inferConstraintsDAC inst_tys
meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }
; theta_origins <- lift $ mapM do_one_meth gen_dms
; return (theta_origins, tvs, inst_tys) }
; return theta_origins }
-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and
-- @DerivingVia@. Since both strategies generate code involving 'coerce', the
-- inferred constraints set up the scaffolding needed to typecheck those uses
-- of 'coerce'. In this example:
--
-- > newtype Age = MkAge Int deriving newtype Num
--
-- We would infer the following constraints ('ThetaOrigin's):