[Git][ghc/ghc][wip/T16341] 3 commits: Add regression test for #16341
Brandon Chinn
gitlab at gitlab.haskell.org
Sun Jul 19 07:26:43 UTC 2020
Brandon Chinn pushed to branch wip/T16341 at Glasgow Haskell Compiler / GHC
Commits:
c8017b36 by Brandon Chinn at 2020-07-19T00:26:26-07:00
Add regression test for #16341
- - - - -
6d9632b9 by Brandon Chinn at 2020-07-19T00:26:26-07:00
Pass inst_tys to more stock-deriving generation functions
- - - - -
41c5d721 by Brandon Chinn at 2020-07-19T00:26:26-07:00
Filter out unreachable constructors when deriving stock instances (#16341)
- - - - -
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
=====================================
@@ -2041,6 +2041,7 @@ genDerivStuff mechanism loc clas inst_tys tyvars
DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc}
, dsm_stock_gen_fn = gen_fn }
-> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+ traceTc "brandonchinn_genDerivStuff" (pprLHsBinds binds)
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 inst_tys = 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 inst_tys) $ 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 inst_tys = 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 inst_tys) $ 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 inst_tys
= (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 inst_tys) $ 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 inst_tys
= (unitBag shows_prec, emptyBag)
where
- data_cons = tyConDataCons tycon
+ data_cons = filter (not . dataConCannotMatch inst_tys) $ 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 inst_tys
= 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 inst_tys) $ tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -595,13 +595,13 @@ 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 inst_tys
+ = do { (binds, deriv_stuff) <- gen_fn loc tc inst_tys
; return (binds, deriv_stuff, []) }
- read_or_show gen_fn loc tc _
+ read_or_show gen_fn loc tc inst_tys
= 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 inst_tys
field_names = all_field_names tc
; return (binds, deriv_stuff, field_names) }
=====================================
testsuite/tests/deriving/should_compile/T16341.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T16341 where
+
+import Data.Data (Data)
+import Data.Ix (Ix)
+
+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 Ix (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/1e9cde15ecb30b310dc04e0384d60c72f6626f78...41c5d721a14671474f8f76ccb15f37d1ac0e2289
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e9cde15ecb30b310dc04e0384d60c72f6626f78...41c5d721a14671474f8f76ccb15f37d1ac0e2289
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/20200719/099a0d80/attachment-0001.html>
More information about the ghc-commits
mailing list