Commit 44b11bad authored by Brandon Chinn's avatar Brandon Chinn Committed by Marge Bot

Filter out unreachable constructors when deriving stock instances (#16431)

parent a26498da
Pipeline #22785 passed with stages
in 427 minutes and 32 seconds
......@@ -165,10 +165,10 @@ gen_Functor_binds loc tycon _
coerce_Expr]
fmap_match_ctxt = mkPrefixFunRhs fmap_name
gen_Functor_binds loc tycon _
gen_Functor_binds loc tycon tycon_args
= (listToBag [fmap_bind, replace_bind], emptyBag)
where
data_cons = tyConDataCons tycon
data_cons = getPossibleDataCons tycon tycon_args
fmap_name = L loc fmap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
......@@ -801,7 +801,7 @@ gen_Foldable_binds loc tycon _
mempty_Expr]
foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
gen_Foldable_binds loc tycon _
gen_Foldable_binds loc tycon tycon_args
| null data_cons -- There's no real point producing anything but
-- foldMap for a type with no constructors.
= (unitBag foldMap_bind, emptyBag)
......@@ -809,7 +809,7 @@ gen_Foldable_binds loc tycon _
| otherwise
= (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
where
data_cons = tyConDataCons tycon
data_cons = getPossibleDataCons tycon tycon_args
foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
......@@ -1031,10 +1031,10 @@ gen_Traversable_binds loc tycon _
(nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
traverse_match_ctxt = mkPrefixFunRhs traverse_name
gen_Traversable_binds loc tycon _
gen_Traversable_binds loc tycon tycon_args
= (unitBag traverse_bind, emptyBag)
where
data_cons = tyConDataCons tycon
data_cons = getPossibleDataCons tycon tycon_args
traverse_name = L loc traverse_RDR
......
......@@ -33,7 +33,9 @@ module GHC.Tc.Deriv.Generate (
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
getPossibleDataCons, tyConInstArgTys
) where
#include "HsVersions.h"
......@@ -213,13 +215,13 @@ produced don't get through the typechecker.
-}
gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Eq_binds loc tycon _ = do
gen_Eq_binds loc tycon tycon_args = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
return (method_binds con2tag_RDR, aux_binds con2tag_RDR)
where
all_cons = tyConDataCons tycon
all_cons = getPossibleDataCons tycon tycon_args
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
-- If there are ten or more (arbitrary number) nullary constructors,
......@@ -397,7 +399,7 @@ gtResult OrdGT = true_Expr
------------
gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ord_binds loc tycon _ = do
gen_Ord_binds loc tycon tycon_args = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
......@@ -432,7 +434,7 @@ gen_Ord_binds loc tycon _ = do
-- We want *zero-based* tags, because that's what
-- con2Tag returns (generated by untag_Expr)!
tycon_data_cons = tyConDataCons tycon
tycon_data_cons = getPossibleDataCons tycon tycon_args
single_con_type = isSingleton tycon_data_cons
(first_con : _) = tycon_data_cons
(last_con : _) = reverse tycon_data_cons
......@@ -1215,10 +1217,10 @@ Example
gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
-> (LHsBinds GhcPs, BagDerivStuff)
gen_Show_binds get_fixity loc tycon _
gen_Show_binds get_fixity loc tycon tycon_args
= (unitBag shows_prec, emptyBag)
where
data_cons = tyConDataCons tycon
data_cons = getPossibleDataCons tycon tycon_args
shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
comma_space = nlHsVar showCommaSpace_RDR
......@@ -1618,7 +1620,7 @@ Example:
gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Lift_binds loc tycon _ = (listToBag [lift_bind, liftTyped_bind], emptyBag)
gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
(map (pats_etc mk_exp) data_cons)
......@@ -1627,7 +1629,7 @@ gen_Lift_binds loc tycon _ = (listToBag [lift_bind, liftTyped_bind], emptyBag)
mk_exp = ExpBr noExtField
mk_texp = TExpBr noExtField
data_cons = tyConDataCons tycon
data_cons = getPossibleDataCons tycon tycon_args
pats_etc mk_bracket data_con
= ([con_pat], lift_Expr)
......@@ -2516,6 +2518,39 @@ newAuxBinderRdrName loc parent occ_fun = do
uniq <- newUnique
pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
-- whose return types match when checked against @tycon_args@.
--
-- See Note [Filter out impossible GADT data constructors]
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
where
isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)
-- | Given a type constructor @tycon@ of arity /n/ and a list of argument types
-- @tycon_args@ of length /m/,
--
-- @
-- tyConInstArgTys tycon tycon_args
-- @
--
-- returns
--
-- @
-- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]
-- @
--
-- where @extra_args@ are distinct type variables.
--
-- Examples:
--
-- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.
--
-- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.
tyConInstArgTys :: TyCon -> [Type] -> [Type]
tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix
where
tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon
{-
Note [Auxiliary binders]
......@@ -2734,4 +2769,56 @@ derived instances within the same module, not separated by any TH splices.
(This is the case described in "Wrinkle: Reducing code duplication".) In
situation (1), we can at least fall back on GHC's simplifier to pick up
genAuxBinds' slack.
Note [Filter out impossible GADT data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some stock-derivable classes will filter out impossible GADT data constructors,
to rule out problematic constructors when deriving instances. e.g.
```
data Foo a where
X :: Foo Int
Y :: (Bool -> Bool) -> Foo Bool
```
when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
exist in the first place. For instance, if we write
```
deriving instance Eq (Foo Int)
```
it should generate:
```
instance Eq (Foo Int) where
X == X = True
```
Classes that filter constructors:
* Eq
* Ord
* Show
* Lift
* Functor
* Foldable
* Traversable
Classes that do not filter constructors:
* Enum: doesn't make sense for GADTs in the first place
* Bounded: only makes sense for GADTs with a single constructor
* Ix: only makes sense for GADTs with a single constructor
* Read: `Read a` returns `a` instead of consumes `a`, so filtering data
constructors would make this function _more_ partial instead of less
* Data: derived implementations of gunfold rely on a constructor-indexing
scheme that wouldn't work if certain constructors were filtered out
* Generic/Generic1: doesn't make sense for GADTs
Classes that do not currently filter constructors may do so in the future, if
there is a valid use-case and we have requirements for how they should work.
See #16341 and the T16341.hs test case.
-}
......@@ -260,9 +260,7 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys
-- substitute each type variable with its counterpart in the derived
-- instance. rep_tc_args lists each of these counterpart types in
-- the same order as the type variables.
all_rep_tc_args
= rep_tc_args ++ map mkTyVarTy
(drop (length rep_tc_args) rep_tc_tvs)
all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args
-- Stupid constraints
stupid_constraints
......
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