summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBrandon Chinn <brandon@leapyear.io>2020-07-21 11:22:42 -0700
committerBrandon Chinn <brandon@leapyear.io>2020-07-28 10:17:14 -0700
commit0f9341151f108915a77f8e5cf8299dc0c6bf322f (patch)
tree227c400b6efb4783ee7592bccbd9cde6d93c1671
parent9bcafe7df7660a39c3064aa914c492bcb16e5573 (diff)
downloadhaskell-wip/T16341.tar.gz
Filter out unreachable constructors when deriving stock instances (#16431)wip/T16341
-rw-r--r--compiler/GHC/Tc/Deriv/Functor.hs12
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs105
-rw-r--r--compiler/GHC/Tc/Deriv/Infer.hs4
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