[Git][ghc/ghc][wip/T16341] 4 commits: Add regression test for #16341
Brandon Chinn
gitlab at gitlab.haskell.org
Tue Jul 28 17:17:23 UTC 2020
Brandon Chinn pushed to branch wip/T16341 at Glasgow Haskell Compiler / GHC
Commits:
cb08e8f3 by Brandon Chinn at 2020-07-28T09:59:42-07:00
Add regression test for #16341
- - - - -
e095d091 by Brandon Chinn at 2020-07-28T09:59:43-07:00
Pass dit_rep_tc_args to dsm_stock_gen_fn
- - - - -
9bcafe7d by Brandon Chinn at 2020-07-28T10:14:49-07:00
Pass tc_args to gen_fn
- - - - -
0f934115 by Brandon Chinn at 2020-07-28T10:17:14-07:00
Filter out unreachable constructors when deriving stock instances (#16431)
- - - - -
7 changed files:
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Functor.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Infer.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- + testsuite/tests/deriving/should_compile/T16341.hs
- testsuite/tests/deriving/should_compile/all.T
Changes:
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -2038,9 +2038,12 @@ genDerivStuff mechanism loc clas inst_tys tyvars
-> gen_newtype_or_via rhs_ty
-- Try a stock deriver
- DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc}
+ DerivSpecStock { dsm_stock_dit = DerivInstTys
+ { dit_rep_tc = rep_tc
+ , dit_rep_tc_args = rep_tc_args
+ }
, dsm_stock_gen_fn = gen_fn }
- -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+ -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys
pure (binds, [], faminsts, field_names)
-- Try DeriveAnyClass
=====================================
compiler/GHC/Tc/Deriv/Functor.hs
=====================================
@@ -151,10 +151,10 @@ is a similar algorithm for generating `p <$ x` (for some constant `p`):
$(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
-}
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-- When the argument is phantom, we can use fmap _ = coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon _
| Phantom <- last (tyConRoles tycon)
= (unitBag fmap_bind, emptyBag)
where
@@ -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]
@@ -787,10 +787,10 @@ could surprise users if they switch to other types, but Ryan Scott seems to
think it's okay to do it for now.
-}
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-- When the parameter is phantom, we can use foldMap _ _ = mempty
-- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon _
| Phantom <- last (tyConRoles tycon)
= (unitBag foldMap_bind, emptyBag)
where
@@ -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
@@ -1016,10 +1016,10 @@ removes all such types from consideration.
See Note [Generated code for DeriveFoldable and DeriveTraversable].
-}
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-- When the argument is phantom, we can use traverse = pure . coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon _
| Phantom <- last (tyConRoles tycon)
= (unitBag traverse_bind, emptyBag)
where
@@ -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
=====================================
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"
@@ -212,14 +214,14 @@ for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
-}
-gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Eq_binds loc tycon = do
+gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+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,
@@ -396,8 +398,8 @@ gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
------------
-gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ord_binds loc tycon = do
+gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+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
@@ -646,8 +648,8 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
-}
-gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Enum_binds loc tycon = do
+gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon _ = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -738,8 +740,8 @@ gen_Enum_binds loc tycon = do
************************************************************************
-}
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Bounded_binds loc tycon
+gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc tycon _
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
| otherwise
@@ -825,9 +827,9 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
-}
-gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ix_binds loc tycon = do
+gen_Ix_binds loc tycon _ = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -1028,10 +1030,10 @@ These instances are also useful for Read (Either Int Emp), where
we want to be able to parse (Left 3) just fine.
-}
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Read_binds get_fixity loc tycon
+gen_Read_binds get_fixity loc tycon _
= (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
-----------------------------------------------------------------------
@@ -1212,13 +1214,13 @@ Example
-- the most tightly-binding operator
-}
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+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
@@ -1385,9 +1387,10 @@ we generate
gen_Data_binds :: SrcSpan
-> TyCon -- For data families, this is the
-- *representation* TyCon
+ -> [Type]
-> TcM (LHsBinds GhcPs, -- The method bindings
BagDerivStuff) -- Auxiliary bindings
-gen_Data_binds loc rep_tc
+gen_Data_binds loc rep_tc _
= do { -- See Note [Auxiliary binders]
dataT_RDR <- new_dataT_rdr_name loc rep_tc
; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
@@ -1616,8 +1619,8 @@ Example:
-}
-gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
+gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+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)
@@ -1626,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)
@@ -2515,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 at .
+--
+-- 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]
@@ -2733,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.
-}
=====================================
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
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -218,8 +218,9 @@ data DerivSpecMechanism
-- instance, including what type constructor the last argument is
-- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
, dsm_stock_gen_fn ::
- SrcSpan -> TyCon
- -> [Type]
+ SrcSpan -> TyCon -- dit_rep_tc
+ -> [Type] -- dit_rep_tc_args
+ -> [Type] -- inst_tys
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
-- ^ This function returns three things:
--
@@ -424,7 +425,7 @@ instance Outputable DerivContext where
-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
data OriginativeDerivStatus
= CanDeriveStock -- Stock class, can derive
- (SrcSpan -> TyCon -> [Type]
+ (SrcSpan -> TyCon -> [Type] -> [Type]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
| StockClassError SDoc -- Stock class, but can't do it
| CanDeriveAnyClass -- See Note [Deriving any class]
@@ -563,6 +564,7 @@ hasStockDeriving
:: Class -> Maybe (SrcSpan
-> TyCon
-> [Type]
+ -> [Type]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
hasStockDeriving clas
= assocMaybe gen_list (getUnique clas)
@@ -571,6 +573,7 @@ hasStockDeriving clas
:: [(Unique, SrcSpan
-> TyCon
-> [Type]
+ -> [Type]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
gen_list = [ (eqClassKey, simpleM gen_Eq_binds)
, (ordClassKey, simpleM gen_Ord_binds)
@@ -587,25 +590,25 @@ hasStockDeriving clas
, (genClassKey, generic (gen_Generic_binds Gen0))
, (gen1ClassKey, generic (gen_Generic_binds Gen1)) ]
- simple gen_fn loc tc _
- = let (binds, deriv_stuff) = gen_fn loc tc
+ simple gen_fn loc tc tc_args _
+ = let (binds, deriv_stuff) = gen_fn loc tc tc_args
in return (binds, deriv_stuff, [])
-- Like `simple`, but monadic. The only monadic thing that these functions
-- do is allocate new Uniques, which are used for generating the names of
-- auxiliary bindings.
-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
- simpleM gen_fn loc tc _
- = do { (binds, deriv_stuff) <- gen_fn loc tc
+ simpleM gen_fn loc tc tc_args _
+ = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
; return (binds, deriv_stuff, []) }
- read_or_show gen_fn loc tc _
+ read_or_show gen_fn loc tc tc_args _
= do { fix_env <- getDataConFixityFun tc
- ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+ ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args
field_names = all_field_names tc
; return (binds, deriv_stuff, field_names) }
- generic gen_fn _ tc inst_tys
+ generic gen_fn _ tc _ inst_tys
= do { (binds, faminst) <- gen_fn tc inst_tys
; let field_names = all_field_names tc
; return (binds, unitBag (DerivFamInst faminst), field_names) }
=====================================
testsuite/tests/deriving/should_compile/T16341.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T16341 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Foo a where
+ Foo1 :: Foo Int
+ Foo2 :: (Bool -> Bool) -> Foo Bool
+
+-- These instances should work whether or not `Foo2` is a constructor in
+-- `Foo`, because the `Foo Int` designation precludes `Foo2` from being
+-- a reachable constructor
+deriving instance Show (Foo Int)
+deriving instance Eq (Foo Int)
+deriving instance Ord (Foo Int)
+deriving instance Lift (Foo Int)
+
+data Bar a b where
+ Bar1 :: b -> Bar Int b
+ Bar2 :: (Bool -> Bool) -> b -> Bar Bool b
+
+deriving instance Functor (Bar Int)
+deriving instance Foldable (Bar Int)
+deriving instance Traversable (Bar Int)
=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -118,6 +118,7 @@ test('T15398', normal, compile, [''])
test('T15637', normal, compile, [''])
test('T15831', normal, compile, [''])
test('T16179', normal, compile, [''])
+test('T16341', normal, compile, [''])
test('T16518', normal, compile, [''])
test('T17324', normal, compile, [''])
test('T17339', normal, compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91fa5efabb15b2467296791472c169271bbff455...0f9341151f108915a77f8e5cf8299dc0c6bf322f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91fa5efabb15b2467296791472c169271bbff455...0f9341151f108915a77f8e5cf8299dc0c6bf322f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200728/263824a5/attachment-0001.html>
More information about the ghc-commits
mailing list