diff options
Diffstat (limited to 'compiler/GHC/Tc/Deriv/Generate.hs')
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 105 |
1 files changed, 96 insertions, 9 deletions
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. -} |