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

3 files changed, 103 insertions, 18 deletions

diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index cb00d85be9..c0566c0ede 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -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
 
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 993c8fd11d..141acdc3a6 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -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.
 -}
diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
index f110b8c7f2..370c06f779 100644
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ b/compiler/GHC/Tc/Deriv/Infer.hs
@@ -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