[Git][ghc/ghc][wip/T16341] 2 commits: Pass inst_tys to more stock-deriving generation functions
Brandon Chinn
gitlab at gitlab.haskell.org
Mon Jul 20 23:58:21 UTC 2020
Brandon Chinn pushed to branch wip/T16341 at Glasgow Haskell Compiler / GHC
Commits:
1d2a829b by Brandon Chinn at 2020-07-20T16:00:51-07:00
Pass inst_tys to more stock-deriving generation functions
- - - - -
130146ce by Brandon Chinn at 2020-07-20T16:04:12-07:00
Filter out unreachable constructors when deriving stock instances (#16341)
- - - - -
2 changed files:
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Utils.hs
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) }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/41c5d721a14671474f8f76ccb15f37d1ac0e2289...130146cec83f1e1ba1ba695081e21f4de827e64f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/41c5d721a14671474f8f76ccb15f37d1ac0e2289...130146cec83f1e1ba1ba695081e21f4de827e64f
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/11c30b5a/attachment-0001.html>
More information about the ghc-commits
mailing list