[Git][ghc/ghc][wip/T16341] 4 commits: Add regression test for #16341
Brandon Chinn
gitlab at gitlab.haskell.org
Tue Jul 21 19:25:07 UTC 2020
Brandon Chinn pushed to branch wip/T16341 at Glasgow Haskell Compiler / GHC
Commits:
556f3cb7 by Brandon Chinn at 2020-07-21T12:24:59-07:00
Add regression test for #16341
- - - - -
ce5eb2e5 by Brandon Chinn at 2020-07-21T12:24:59-07:00
Pass dit_rep_tc_args to dsm_stock_gen_fn
- - - - -
2b16976f by Brandon Chinn at 2020-07-21T12:24:59-07:00
Pass tc_args to gen_fn
- - - - -
decaba57 by Brandon Chinn at 2020-07-21T12:24:59-07:00
Filter out unreachable constructors when deriving stock instances (#16431)
- - - - -
5 changed files:
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.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/Generate.hs
=====================================
@@ -212,14 +212,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 = filter (not . dataConCannotMatch tycon_args) $ tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
-- If there are ten or more (arbitrary number) nullary constructors,
@@ -396,8 +396,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 +432,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 = filter (not . dataConCannotMatch tycon_args) $ tyConDataCons tycon
single_con_type = isSingleton tycon_data_cons
(first_con : _) = tycon_data_cons
(last_con : _) = reverse tycon_data_cons
@@ -646,8 +646,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
@@ -825,9 +825,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 +1028,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 tycon_args
= (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
-----------------------------------------------------------------------
@@ -1042,7 +1042,7 @@ gen_Read_binds get_fixity loc tycon
= mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
-----------------------------------------------------------------------
- data_cons = tyConDataCons tycon
+ data_cons = filter (not . dataConCannotMatch tycon_args) $ tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
read_prec = mkHsVarBind loc readPrec_RDR rhs
@@ -1212,13 +1212,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 = filter (not . dataConCannotMatch tycon_args) $ tyConDataCons tycon
shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
comma_space = nlHsVar showCommaSpace_RDR
@@ -1385,9 +1385,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 rep_tc_args
= do { -- See Note [Auxiliary binders]
dataT_RDR <- new_dataT_rdr_name loc rep_tc
; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
@@ -1403,7 +1404,7 @@ gen_Data_binds loc rep_tc
data_cons dataC_RDRs )
) }
where
- data_cons = tyConDataCons rep_tc
+ data_cons = filter (not . dataConCannotMatch rep_tc_args) $ tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
=====================================
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,7 +590,7 @@ hasStockDeriving clas
, (genClassKey, generic (gen_Generic_binds Gen0))
, (gen1ClassKey, generic (gen_Generic_binds Gen1)) ]
- simple gen_fn loc tc _
+ simple gen_fn loc tc _ _
= let (binds, deriv_stuff) = gen_fn loc tc
in return (binds, deriv_stuff, [])
@@ -595,17 +598,17 @@ hasStockDeriving clas
-- 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,21 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T16341 where
+
+import Data.Data (Data)
+
+data Foo a where
+ X :: Foo Int
+ Y :: (Bool -> Bool) -> Foo Bool
+
+-- These instances should work whether or not `Y` is a constructor in
+-- `Foo`, because the `Foo Int` designation precludes `Y` from being
+-- a reachable constructor
+deriving instance Show (Foo Int)
+deriving instance Read (Foo Int)
+deriving instance Eq (Foo Int)
+deriving instance Ord (Foo Int)
+deriving instance Data (Foo 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/fd5e1083d65d9259ab9c389b3404f5a60a55a5bc...decaba57ace9365947e8d3c3cc5c483adc86b456
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd5e1083d65d9259ab9c389b3404f5a60a55a5bc...decaba57ace9365947e8d3c3cc5c483adc86b456
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/20200721/e59a8f59/attachment-0001.html>
More information about the ghc-commits
mailing list