[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