[Git][ghc/ghc][master] 4 commits: Add regression test for #16341

Marge Bot gitlab at gitlab.haskell.org
Wed Jul 29 19:07:19 UTC 2020



 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
c59064b0 by Brandon Chinn at 2020-07-29T15:07:11-04:00
Add regression test for #16341

- - - - -
a61411ca by Brandon Chinn at 2020-07-29T15:07:11-04:00
Pass dit_rep_tc_args to dsm_stock_gen_fn

- - - - -
a26498da by Brandon Chinn at 2020-07-29T15:07:11-04:00
Pass tc_args to gen_fn

- - - - -
44b11bad by Brandon Chinn at 2020-07-29T15:07:11-04:00
Filter out unreachable constructors when deriving stock instances (#16431)

- - - - -


7 changed files:

- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Functor.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Infer.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
=====================================
@@ -2038,9 +2038,12 @@ genDerivStuff mechanism loc clas inst_tys tyvars
         -> gen_newtype_or_via rhs_ty
 
       -- Try a stock deriver
-      DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}
+      DerivSpecStock { dsm_stock_dit    = DerivInstTys
+                        { dit_rep_tc = rep_tc
+                        , dit_rep_tc_args = rep_tc_args
+                        }
                      , dsm_stock_gen_fn = gen_fn }
-        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys
               pure (binds, [], faminsts, field_names)
 
       -- Try DeriveAnyClass


=====================================
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, tyConInstArgTys
     ) where
 
 #include "HsVersions.h"
@@ -212,14 +214,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 tycon_args = 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 = getPossibleDataCons tycon tycon_args
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
 
     -- If there are ten or more (arbitrary number) nullary constructors,
@@ -396,8 +398,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 tycon_args = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
 
@@ -432,7 +434,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 = getPossibleDataCons tycon tycon_args
     single_con_type = isSingleton tycon_data_cons
     (first_con : _) = tycon_data_cons
     (last_con : _)  = reverse tycon_data_cons
@@ -646,8 +648,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
@@ -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
@@ -825,9 +827,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 +1030,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 _
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
   where
     -----------------------------------------------------------------------
@@ -1212,13 +1214,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 tycon_args
   = (unitBag shows_prec, emptyBag)
   where
-    data_cons = 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
 
@@ -1385,9 +1387,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 _
   = do { -- See Note [Auxiliary binders]
          dataT_RDR  <- new_dataT_rdr_name loc rep_tc
        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
@@ -1616,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)
@@ -1626,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)
@@ -2515,6 +2518,39 @@ newAuxBinderRdrName loc parent occ_fun = do
   uniq <- newUnique
   pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
 
+-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
+-- whose return types match when checked against @tycon_args at .
+--
+-- See Note [Filter out impossible GADT data constructors]
+getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
+getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
+  where
+    isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)
+
+-- | Given a type constructor @tycon@ of arity /n/ and a list of argument types
+-- @tycon_args@ of length /m/,
+--
+-- @
+-- tyConInstArgTys tycon tycon_args
+-- @
+--
+-- returns
+--
+-- @
+-- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]
+-- @
+--
+-- where @extra_args@ are distinct type variables.
+--
+-- Examples:
+--
+-- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.
+--
+-- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.
+tyConInstArgTys :: TyCon -> [Type] -> [Type]
+tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix
+  where
+    tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon
 
 {-
 Note [Auxiliary binders]
@@ -2733,4 +2769,56 @@ derived instances within the same module, not separated by any TH splices.
 (This is the case described in "Wrinkle: Reducing code duplication".) In
 situation (1), we can at least fall back on GHC's simplifier to pick up
 genAuxBinds' slack.
+
+Note [Filter out impossible GADT data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Some stock-derivable classes will filter out impossible GADT data constructors,
+to rule out problematic constructors when deriving instances. e.g.
+
+```
+data Foo a where
+  X :: Foo Int
+  Y :: (Bool -> Bool) -> Foo Bool
+```
+
+when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
+exist in the first place. For instance, if we write
+
+```
+deriving instance Eq (Foo Int)
+```
+
+it should generate:
+
+```
+instance Eq (Foo Int) where
+  X == X = True
+```
+
+Classes that filter constructors:
+
+* Eq
+* Ord
+* Show
+* Lift
+* Functor
+* Foldable
+* Traversable
+
+Classes that do not filter constructors:
+
+* Enum: doesn't make sense for GADTs in the first place
+* Bounded: only makes sense for GADTs with a single constructor
+* Ix: only makes sense for GADTs with a single constructor
+* Read: `Read a` returns `a` instead of consumes `a`, so filtering data
+  constructors would make this function _more_ partial instead of less
+* Data: derived implementations of gunfold rely on a constructor-indexing
+  scheme that wouldn't work if certain constructors were filtered out
+* Generic/Generic1: doesn't make sense for GADTs
+
+Classes that do not currently filter constructors may do so in the future, if
+there is a valid use-case and we have requirements for how they should work.
+
+See #16341 and the T16341.hs test case.
 -}


=====================================
compiler/GHC/Tc/Deriv/Infer.hs
=====================================
@@ -260,9 +260,7 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
            -- substitute each type variable with its counterpart in the derived
            -- instance. rep_tc_args lists each of these counterpart types in
            -- the same order as the type variables.
-           all_rep_tc_args
-             = rep_tc_args ++ map mkTyVarTy
-                                  (drop (length rep_tc_args) rep_tc_tvs)
+           all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args
 
                -- Stupid constraints
            stupid_constraints


=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -218,8 +218,9 @@ data DerivSpecMechanism
       -- instance, including what type constructor the last argument is
       -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
     , dsm_stock_gen_fn ::
-        SrcSpan -> TyCon
-                -> [Type]
+        SrcSpan -> TyCon  -- dit_rep_tc
+                -> [Type] -- dit_rep_tc_args
+                -> [Type] -- inst_tys
                 -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
       -- ^ This function returns three things:
       --
@@ -424,7 +425,7 @@ instance Outputable DerivContext where
 -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
 data OriginativeDerivStatus
   = CanDeriveStock            -- Stock class, can derive
-      (SrcSpan -> TyCon -> [Type]
+      (SrcSpan -> TyCon -> [Type] -> [Type]
                -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
   | StockClassError SDoc      -- Stock class, but can't do it
   | CanDeriveAnyClass         -- See Note [Deriving any class]
@@ -563,6 +564,7 @@ hasStockDeriving
   :: Class -> Maybe (SrcSpan
                      -> TyCon
                      -> [Type]
+                     -> [Type]
                      -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
 hasStockDeriving clas
   = assocMaybe gen_list (getUnique clas)
@@ -571,6 +573,7 @@ hasStockDeriving clas
       :: [(Unique, SrcSpan
                    -> TyCon
                    -> [Type]
+                   -> [Type]
                    -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
     gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
                , (ordClassKey,         simpleM gen_Ord_binds)
@@ -587,25 +590,25 @@ 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
     -- 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 tc_args _
+      = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
            ; return (binds, deriv_stuff, []) }
 
-    read_or_show gen_fn loc tc _
+    read_or_show gen_fn loc tc tc_args _
       = 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 tc_args
                  field_names          = all_field_names tc
            ; return (binds, deriv_stuff, field_names) }
 
-    generic gen_fn _ tc inst_tys
+    generic gen_fn _ tc _ inst_tys
       = do { (binds, faminst) <- gen_fn tc inst_tys
            ; let field_names = all_field_names tc
            ; return (binds, unitBag (DerivFamInst faminst), field_names) }


=====================================
testsuite/tests/deriving/should_compile/T16341.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T16341 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Foo a where
+  Foo1 :: Foo Int
+  Foo2 :: (Bool -> Bool) -> Foo Bool
+
+-- 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 Eq (Foo Int)
+deriving instance Ord (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)


=====================================
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/b9a880fce484d0a87bb794b9d2d8a73e54819011...44b11bad052eabf43246acba6aab814376b08713

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9a880fce484d0a87bb794b9d2d8a73e54819011...44b11bad052eabf43246acba6aab814376b08713
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/20200729/08d18d38/attachment-0001.html>


More information about the ghc-commits mailing list