[Git][ghc/ghc][wip/T16341] 3 commits: Add regression test for #16341
Brandon Chinn
gitlab at gitlab.haskell.org
Mon Jul 20 23:59:43 UTC 2020
Brandon Chinn pushed to branch wip/T16341 at Glasgow Haskell Compiler / GHC
Commits:
d9da1e86 by Brandon Chinn at 2020-07-20T16:59:29-07:00
Add regression test for #16341
- - - - -
c6a411ae by Brandon Chinn at 2020-07-20T16:59:35-07:00
Pass inst_tys to more stock-deriving generation functions
- - - - -
fd5e1083 by Brandon Chinn at 2020-07-20T16:59:35-07:00
Filter out unreachable constructors when deriving stock instances (#16341)
- - - - -
4 changed files:
- 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/Generate.hs
=====================================
@@ -212,14 +212,20 @@ 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 -- ^ The type being derived
+ -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon ty = 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
+ filterImpossibleDataCons = case splitTyConApp_maybe ty of
+ Just (_, inst_tys) -> filter (not . dataConCannotMatch inst_tys)
+ _ -> id
+ all_cons = filterImpossibleDataCons $ tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
-- If there are ten or more (arbitrary number) nullary constructors,
@@ -396,8 +402,11 @@ 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 -- ^ The type being derived
+ -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon ty = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
@@ -432,7 +441,10 @@ 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
+ filterImpossibleDataCons = case splitTyConApp_maybe ty of
+ Just (_, inst_tys) -> filter (not . dataConCannotMatch inst_tys)
+ _ -> id
+ tycon_data_cons = filterImpossibleDataCons $ tyConDataCons tycon
single_con_type = isSingleton tycon_data_cons
(first_con : _) = tycon_data_cons
(last_con : _) = reverse tycon_data_cons
@@ -646,8 +658,11 @@ 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 -- ^ The type being derived
+ -> 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 +840,12 @@ 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 -- ^ The type being derived
+ -> 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 +1046,13 @@ 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 -- ^ The type being derived
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Read_binds get_fixity loc tycon
+gen_Read_binds get_fixity loc tycon ty
= (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
-----------------------------------------------------------------------
@@ -1042,7 +1063,10 @@ gen_Read_binds get_fixity loc tycon
= mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
-----------------------------------------------------------------------
- data_cons = tyConDataCons tycon
+ filterImpossibleDataCons = case splitTyConApp_maybe ty of
+ Just (_, inst_tys) -> filter (not . dataConCannotMatch inst_tys)
+ _ -> id
+ data_cons = filterImpossibleDataCons $ tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
read_prec = mkHsVarBind loc readPrec_RDR rhs
@@ -1212,13 +1236,19 @@ Example
-- the most tightly-binding operator
-}
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Show_binds :: (Name -> Fixity)
+ -> SrcSpan
+ -> TyCon
+ -> Type -- ^ The type being derived
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Show_binds get_fixity loc tycon
+gen_Show_binds get_fixity loc tycon ty
= (unitBag shows_prec, emptyBag)
where
- data_cons = tyConDataCons tycon
+ filterImpossibleDataCons = case splitTyConApp_maybe ty of
+ Just (_, inst_tys) -> filter (not . dataConCannotMatch inst_tys)
+ _ -> id
+ data_cons = filterImpossibleDataCons $ tyConDataCons tycon
shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
comma_space = nlHsVar showCommaSpace_RDR
@@ -1385,9 +1415,10 @@ we generate
gen_Data_binds :: SrcSpan
-> TyCon -- For data families, this is the
-- *representation* TyCon
+ -> Type -- ^ The type being derived
-> TcM (LHsBinds GhcPs, -- The method bindings
BagDerivStuff) -- Auxiliary bindings
-gen_Data_binds loc rep_tc
+gen_Data_binds loc rep_tc ty
= 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 +1434,10 @@ gen_Data_binds loc rep_tc
data_cons dataC_RDRs )
) }
where
- data_cons = tyConDataCons rep_tc
+ filterImpossibleDataCons = case splitTyConApp_maybe ty of
+ Just (_, inst_tys) -> filter (not . dataConCannotMatch inst_tys)
+ _ -> id
+ data_cons = filterImpossibleDataCons $ tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -595,13 +595,23 @@ 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 { let inst_ty = case inst_tys of
+ [ty] -> ty
+ -- should not happen, since simpleM is only derived for
+ -- classes with a single type parameter
+ _ -> pprPanic "hasStockDeriving.simpleM" (ppr inst_tys)
+ ; (binds, deriv_stuff) <- gen_fn loc tc inst_ty
; return (binds, deriv_stuff, []) }
- read_or_show gen_fn loc tc _
- = do { fix_env <- getDataConFixityFun tc
- ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+ read_or_show gen_fn loc tc inst_tys
+ = do { let inst_ty = case inst_tys of
+ [ty] -> ty
+ -- should not happen, since Read and Show only have a
+ -- single type parameter
+ _ -> pprPanic "hasStockDeriving.read_or_show" (ppr inst_tys)
+ ; fix_env <- getDataConFixityFun tc
+ ; let (binds, deriv_stuff) = gen_fn fix_env loc tc inst_ty
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/130146cec83f1e1ba1ba695081e21f4de827e64f...fd5e1083d65d9259ab9c389b3404f5a60a55a5bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/130146cec83f1e1ba1ba695081e21f4de827e64f...fd5e1083d65d9259ab9c389b3404f5a60a55a5bc
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/20200720/cc76b2fa/attachment-0001.html>
More information about the ghc-commits
mailing list