[Git][ghc/ghc][wip/T16341] 3 commits: Factor out getPossibleDataCons
Brandon Chinn
gitlab at gitlab.haskell.org
Sat Jul 25 23:59:53 UTC 2020
Brandon Chinn pushed to branch wip/T16341 at Glasgow Haskell Compiler / GHC
Commits:
d9a8f6b0 by Brandon Chinn at 2020-07-25T16:49:25-07:00
Factor out getPossibleDataCons
- - - - -
805ceb81 by Brandon Chinn at 2020-07-25T16:55:50-07:00
Filter out impossible constructors for Functor, Foldable, Traversable, Lift
- - - - -
a03e1c0e by Brandon Chinn at 2020-07-25T16:57:33-07:00
Remove filter for deriving Data
- - - - -
4 changed files:
- compiler/GHC/Tc/Deriv/Functor.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- testsuite/tests/deriving/should_compile/T16341.hs
Changes:
=====================================
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
) where
#include "HsVersions.h"
@@ -219,7 +221,7 @@ gen_Eq_binds loc tycon tycon_args = do
return (method_binds con2tag_RDR, aux_binds con2tag_RDR)
where
- all_cons = filter (not . dataConCannotMatch tycon_args) $ 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,
@@ -432,7 +434,7 @@ gen_Ord_binds loc tycon tycon_args = do
-- We want *zero-based* tags, because that's what
-- con2Tag returns (generated by untag_Expr)!
- tycon_data_cons = filter (not . dataConCannotMatch tycon_args) $ 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
@@ -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
@@ -1042,7 +1044,7 @@ gen_Read_binds get_fixity loc tycon tycon_args
= mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
-----------------------------------------------------------------------
- data_cons = filter (not . dataConCannotMatch tycon_args) $ tyConDataCons tycon
+ data_cons = getPossibleDataCons tycon tycon_args
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
read_prec = mkHsVarBind loc readPrec_RDR rhs
@@ -1218,7 +1220,7 @@ gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
gen_Show_binds get_fixity loc tycon tycon_args
= (unitBag shows_prec, emptyBag)
where
- data_cons = filter (not . dataConCannotMatch tycon_args) $ 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
@@ -1388,7 +1390,7 @@ gen_Data_binds :: SrcSpan
-> [Type]
-> TcM (LHsBinds GhcPs, -- The method bindings
BagDerivStuff) -- Auxiliary bindings
-gen_Data_binds loc rep_tc rep_tc_args
+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
@@ -1404,7 +1406,7 @@ gen_Data_binds loc rep_tc rep_tc_args
data_cons dataC_RDRs )
) }
where
- data_cons = filter (not . dataConCannotMatch rep_tc_args) $ tyConDataCons rep_tc
+ data_cons = tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
@@ -1617,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)
@@ -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,12 @@ newAuxBinderRdrName loc parent occ_fun = do
uniq <- newUnique
pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
+-- | If we're deriving an instance for a GADT, e.g. `Eq (Foo Int)`, we should treat any constructors
+-- for which it's impossible to match `Foo Int` as not being there at all.
+--
+-- See #16341 and the T16341.hs test case.
+getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
+getPossibleDataCons tycon tycon_args = filter (not . dataConCannotMatch tycon_args) $ tyConDataCons tycon
{-
Note [Auxiliary binders]
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -590,8 +590,8 @@ 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
=====================================
testsuite/tests/deriving/should_compile/T16341.hs
=====================================
@@ -8,14 +8,22 @@ module T16341 where
import Data.Data (Data)
data Foo a where
- X :: Foo Int
- Y :: (Bool -> Bool) -> Foo Bool
+ Foo1 :: Foo Int
+ Foo2 :: (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
+-- 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 Read (Foo Int)
deriving instance Eq (Foo Int)
deriving instance Ord (Foo Int)
-deriving instance Data (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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/df96714fc1b997dc52166d04b12a3226327c54d4...a03e1c0efe4d34d9dc45aee7d6fbd6d9e9bb1c4d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/df96714fc1b997dc52166d04b12a3226327c54d4...a03e1c0efe4d34d9dc45aee7d6fbd6d9e9bb1c4d
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/20200725/fd5a218f/attachment-0001.html>
More information about the ghc-commits
mailing list