compiler/main/HscTypes.hs

@@ -1684,7 +1684,7 @@ implicitTyConThings tc
     implicitCoTyCon tc ++
 
       -- for each data constructor in order,
-      --   the contructor, worker, and (possibly) wrapper
+      --   the constructor, worker, and (possibly) wrapper
     concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc)
       -- NB. record selectors are *not* implicit, they have fully-fledged
       -- bindings that pass through the compilation pipeline as normal.

compiler/typecheck/Inst.hs

@@ -9,7 +9,7 @@ The @Inst@ type: dictionaries or method instances
 {-# LANGUAGE CPP #-}
 
 module Inst (
-       deeplySkolemise, deeplyInstantiate, 
+       deeplySkolemise, deeplyInstantiate,
        instCall, instDFunType, instStupidTheta,
        newWanted, newWanteds,
        emitWanted, emitWanteds,
@@ -63,7 +63,7 @@ import Data.Maybe( isJust )
 {-
 ************************************************************************
 *                                                                      *
-                Creating and emittind constraints
+                Creating and emitting constraints
 *                                                                      *
 ************************************************************************
 -}

compiler/typecheck/TcDeriv.hs

@@ -48,6 +48,7 @@ import ErrUtils
 import DataCon
 import Maybes
 import RdrName
+import Id ( idType )
 import Name
 import NameSet
 import TyCon
@@ -162,7 +163,9 @@ earlyDSClass :: EarlyDerivSpec -> Class
 earlyDSClass (InferTheta spec) = ds_cls spec
 earlyDSClass (GivenTheta spec) = ds_cls spec
 
-splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaOrigin], [DerivSpec ThetaType])
+splitEarlyDerivSpec :: [EarlyDerivSpec]
+                    -> ( [DerivSpec ThetaOrigin] -- Standard deriving
+                       , [DerivSpec ThetaType])  -- Standlone deriving
 splitEarlyDerivSpec [] = ([],[])
 splitEarlyDerivSpec (InferTheta spec : specs) =
     case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
@@ -362,25 +365,35 @@ tcDeriving tycl_decls inst_decls deriv_decls
         ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
         ; traceTc "tcDeriving 1" (ppr early_specs)
 
-        -- for each type, determine the auxliary declarations that are common
-        -- to multiple derivations involving that type (e.g. Generic and
-        -- Generic1 should use the same TcGenGenerics.MetaTyCons)
-        ; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
+        -- Generic/Generic1 derived instances need to be handled first, because
+        -- we might need the Rep family instances when inferring derived
+        -- contexts (See Note [Inferring contexts for DeriveAnyClass])
+        ; genDerivStuff <- genericAuxiliaries $ map forgetTheta early_specs
+        ; let (newTyCons, famInsts, extraInstances) = splitDerivStuff genDerivStuff
 
-        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
-        ; insts1 <- mapM (genInst commonAuxs) given_specs
+        ; let thingTycons = map ATyCon (bagToList newTyCons)
+        ; tcExtendGlobalEnv thingTycons $
+          tcExtendGlobalEnvImplicit (concatMap implicitTyThings thingTycons) $
+          tcExtendLocalFamInstEnv (bagToList famInsts) $ do {
+
+          let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
+
+        ; insts1 <- mapM genInst given_specs
+        ; let (earlyInstInfos, _, _) = unzip3 insts1
 
         -- the stand-alone derived instances (@insts1@) are used when inferring
         -- the contexts for "deriving" clauses' instances (@infer_specs@)
-        ; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
+        ; final_specs <- extendLocalInstEnv
+                           (map iSpec (earlyInstInfos
+                                      -- Don't forget the Generics instances
+                                    ++ bagToList extraInstances)) $
                          inferInstanceContexts infer_specs
 
-        ; insts2 <- mapM (genInst commonAuxs) final_specs
+        ; insts2 <- mapM genInst final_specs
 
-        ; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
         ; loc <- getSrcSpanM
-        ; let (binds, newTyCons, famInsts, extraInstances) =
-                genAuxBinds loc (unionManyBags (auxDerivStuff : deriv_stuff))
+        ; let (inst_infos, aux_binds, maybe_fvs) = unzip3 (insts1 ++ insts2)
+        ; let binds = genAuxBinds loc (unionManyBags aux_binds)
 
         ; (inst_info, rn_binds, rn_dus) <-
             renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
@@ -390,13 +403,9 @@ tcDeriving tycl_decls inst_decls deriv_decls
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
                         (ddump_deriving inst_info rn_binds newTyCons famInsts))
 
-        ; let all_tycons = map ATyCon (bagToList newTyCons)
-        ; gbl_env <- tcExtendGlobalEnv all_tycons $
-                     tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
-                     tcExtendLocalFamInstEnv (bagToList famInsts) $
-                     tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
+        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
         ; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) }
+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
   where
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
                    -> Bag TyCon               -- ^ Empty data constructors
@@ -423,19 +432,24 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
 
 -- As of 24 April 2012, this only shares MetaTyCons between derivations of
 -- Generic and Generic1; thus the types and logic are quite simple.
-type CommonAuxiliary = MetaTyCons
-type CommonAuxiliaries = [(TyCon, CommonAuxiliary)] -- NSF what is a more efficient map type?
-
-commonAuxiliaries :: [DerivSpec ()] -> TcM (CommonAuxiliaries, BagDerivStuff)
-commonAuxiliaries = foldM snoc ([], emptyBag) where
-  snoc acc@(cas, stuff) (DS {ds_name = nm, ds_cls = cls, ds_tc = rep_tycon})
-    | getUnique cls `elem` [genClassKey, gen1ClassKey] =
-      extendComAux $ genGenericMetaTyCons rep_tycon (nameModule nm)
-    | otherwise = return acc
-   where extendComAux m -- don't run m if its already in the accumulator
-           | any ((rep_tycon ==) . fst) cas = return acc
-           | otherwise = do (ca, new_stuff) <- m
-                            return $ ((rep_tycon, ca) : cas, stuff `unionBags` new_stuff)
+genericAuxiliaries :: [DerivSpec ()] -> TcM BagDerivStuff
+genericAuxiliaries = fmap snd . foldM snoc ([], emptyBag) where
+  snoc acc@(gas, metaTyCons) (DS {ds_name = nm, ds_cls = cls, ds_tc = repTycon})
+    | getUnique cls `elem` [genClassKey, gen1ClassKey] = extendComAux
+    | otherwise                                        = return acc
+   where extendComAux
+           | Just thisMetaTyCons <- lookup repTycon gas
+           -- don't generate new MetaTyCons if we've already done this tycon
+           = do famInst <- tc_mkRepFamInst gk repTycon thisMetaTyCons (nameModule nm)
+                return $ (gas, DerivFamInst famInst `consBag` metaTyCons)
+
+           | otherwise
+           = do (newMetaTyCons, newInstances) <- genGenericMetaTyCons repTycon (nameModule nm)
+                let newGas = (repTycon, newMetaTyCons) : gas
+                famInst <- tc_mkRepFamInst gk repTycon newMetaTyCons (nameModule nm)
+                return $ (newGas, DerivFamInst famInst `consBag` metaTyCons `unionBags` newInstances)
+
+         gk = if getUnique cls == genClassKey then Gen0 else Gen1
 
 renameDeriv :: Bool
             -> [InstInfo RdrName]
@@ -723,8 +737,7 @@ deriveTyData :: Bool                         -- False <=> data/newtype
 deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
     do  { (deriv_tvs, cls, cls_tys, cls_arg_kind)
-                <- tcExtendTyVarEnv tvs $
-                   tcHsDeriv deriv_pred
+                <- tcExtendTyVarEnv tvs (tcHsDeriv deriv_pred)
                 -- Deriving preds may (now) mention
                 -- the type variables for the type constructor, hence tcExtendTyVarenv
                 -- The "deriv_pred" is a LHsType to take account of the fact that for
@@ -772,8 +785,9 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred)
 
         ; traceTc "derivTyData2" (vcat [ ppr univ_tvs ])
 
-        ; checkTc (allDistinctTyVars args_to_drop &&              -- (a) and (b)
-                   not (any (`elemVarSet` dropped_tvs) univ_tvs)) -- (c)
+        ; checkTc (allDistinctTyVars args_to_drop &&  -- (a) and (b)
+                   dropped_tvs `disjointVarSet`
+                     tyVarsOfTypes final_cls_tys)     -- (c)
                   (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
                 -- Check that
                 --  (a) The args to drop are all type variables; eg reject:
@@ -1007,21 +1021,23 @@ mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
         -- NB: pass the *representation* tycon to checkSideConditions
         NonDerivableClass   msg -> bale_out (nonStdErr cls $$ msg)
         DerivableClassError msg -> bale_out msg
-        CanDerive               -> go_for_it
-        DerivableViaInstance    -> go_for_it
+        CanDerive               -> go_for_it True
+        DerivableViaInstance    -> go_for_it False
   where
-    go_for_it    = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-    bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
+    go_for_it std_cls = mk_data_eqn overlap_mode std_cls tvs cls cls_tys tycon
+                                    tc_args rep_tc rep_tc_args mtheta
+    bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                                                (mkTyConApp tycon tc_args) msg)
 
-mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class
+mk_data_eqn :: Maybe OverlapMode -> Bool -> [TyVar] -> Class -> [Type]
             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
             -> TcM EarlyDerivSpec
-mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
+mk_data_eqn overlap_mode std_cls tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta
   = do loc                  <- getSrcSpanM
        dfun_name            <- new_dfun_name cls tycon
        case mtheta of
         Nothing -> do --Infer context
-            inferred_constraints <- inferConstraints cls inst_tys rep_tc rep_tc_args
+            inferred_constraints <- inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
             return $ InferTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs
@@ -1040,7 +1056,7 @@ mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                    , ds_overlap = overlap_mode
                    , ds_newtype = False }
   where
-    inst_tys = [mkTyConApp tycon tc_args]
+    inst_tys = cls_tys ++ [mkTyConApp tycon tc_args]
 
 ----------------------
 
@@ -1076,13 +1092,14 @@ mkPolyKindedTypeableEqn cls tc
           tc_args = mkTyVarTys kvs
           tc_app  = mkTyConApp tc tc_args
 
-inferConstraints :: Class -> [TcType]
+inferConstraints :: Bool
+                 -> Class -> [TcType]
                  -> TyCon -> [TcType]
                  -> TcM ThetaOrigin
 -- Generate a sufficiently large set of constraints that typechecking the
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
-inferConstraints cls inst_tys rep_tc rep_tc_args
+inferConstraints std_cls cls inst_tys rep_tc rep_tc_args
   | cls `hasKey` genClassKey    -- Generic constraints are easy
   = return []
 
@@ -1094,9 +1111,11 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
   | otherwise  -- The others are a bit more complicated
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
     do { traceTc "inferConstraints" (vcat [ppr cls <+> ppr inst_tys, ppr arg_constraints])
-       ; return (stupid_constraints ++ extra_constraints
-                 ++ sc_constraints
-                 ++ arg_constraints) }
+       ; dm_constraints <- get_dm_constraints
+       ; return (stupid_constraints ++ sc_constraints
+                 ++ if std_cls
+                    then extra_constraints ++ arg_constraints
+                    else mkThetaOrigin DerivOrigin (concat dm_constraints)) }
   where
     arg_constraints = con_arg_constraints cls get_std_constrained_tys
 
@@ -1117,11 +1136,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
                 -- (a) We recurse over argument types to generate constraints
                 --     See Functor examples in TcGenDeriv
                 -- (b) The rep_tc_args will be one short
-    is_functor_like =    getUnique cls `elem` functorLikeClassKeys
-                      || onlyOneAndTypeConstr inst_tys
-    onlyOneAndTypeConstr [inst_ty] =
-      typeKind inst_ty `tcEqKind` mkArrowKind liftedTypeKind liftedTypeKind
-    onlyOneAndTypeConstr _         = False
+    is_functor_like = getUnique cls `elem` functorLikeClassKeys
 
     get_std_constrained_tys :: Type -> [Type]
     get_std_constrained_tys ty
@@ -1131,9 +1146,27 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
     rep_tc_tvs = tyConTyVars rep_tc
     last_tv = last rep_tc_tvs
     all_rep_tc_args | cls `hasKey` gen1ClassKey || is_functor_like
-                      = rep_tc_args ++ [mkTyVarTy last_tv]
+                    = rep_tc_args ++ [mkTyVarTy last_tv]
                     | otherwise       = rep_tc_args
 
+        -- Constraints arising from default methods (only for DeriveAnyClass)
+    get_dm_constraints = mapM getDMTheta dms where
+      dms = filter ((/= NoDefMeth) . snd) (classOpItems cls)
+
+      getDMTheta :: ClassOpItem -> TcM ThetaType
+      getDMTheta (_, DefMeth    name) = do tcLookupId name >>= return . getTheta
+      getDMTheta (_, GenDefMeth name) = do tcLookupId name >>= return . getTheta
+      getDMTheta co                   = pprPanic "dm_constraints" (ppr co)
+
+      getTheta :: Id -> ThetaType
+      getTheta i =
+        let (_, ctx1, t)  = tcSplitSigmaTy (idType i)
+            (_, ctx2, _)  = tcSplitSigmaTy t
+            classTyVarSet = mkVarSet (classTyVars cls)
+            usefulCtx     = filter (\p -> tcTyVarsOfType p `subVarSet`
+                                                   classTyVarSet) (ctx1 ++ ctx2)
+        in substTheta (zipOpenTvSubst (classTyVars cls) inst_tys) usefulCtx
+
         -- Constraints arising from superclasses
         -- See Note [Superclasses of derived instance]
     sc_constraints = mkThetaOrigin DerivOrigin $
@@ -1142,7 +1175,10 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
         -- Stupid constraints
     stupid_constraints = mkThetaOrigin DerivOrigin $
         substTheta subst (tyConStupidTheta rep_tc)
-    subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
+    subst = zipTopTvSubst (take (length rep_tc_args) rep_tc_tvs) rep_tc_args
+            -- There might be fewer rep_tc_args than rep_tc_tvs, because we've
+            -- dropped args as necessary to match the kind of the class we're
+            -- generating an instance for
 
         -- Extra Data constraints
         -- The Data class (only) requires that for
@@ -1204,12 +1240,61 @@ if DeriveAnyClass is enabled.
 This is not restricted to Generics; any class can be derived, simply giving
 rise to an empty instance.
 
-Unfortunately, it is not clear how to determine the context (in case of
-standard deriving; in standalone deriving, the user provides the context).
-GHC uses the same heuristic for figuring out the class context that it uses for
-Eq in the case of *-kinded classes, and for Functor in the case of
-* -> *-kinded classes. That may not be optimal or even wrong. But in such
-cases, standalone deriving can still be used.
+Note [Inferring contexts for DeriveAnyClass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With DeriveAnyClass, we infer contexts by looking at the default methods in
+the class we're deriving. For example:
+
+  class C a b where
+    c1 :: Read c => a -> b -> c
+    default c1 :: (Show a, Show b, Read c) => a -> b -> c
+    c1 a b = read (show a ++ show b)
+
+    c2 :: a -> b
+
+  data D = D deriving (C Int)
+
+DeriveAnyClass will generate the following instance:
+
+  instance (Show Int, Show D) => C Int D
+
+We basically use the contexts of the default methods, ignoring constraints that
+mention locally-quantified variables (like `Read c` above). Methods without a
+default are ignored too, because we won't produce code for them in the instance
+(and indeed the code above would warn about a missing `c2` method).
+
+One tricky interaction happens when deriving Generic. Deriving Generic gives
+rises to type family instances (see Note [What deriving Generic/Generic1
+generates] in TcGenGenerics), and these might be required in order to solve
+the constraints generated by DeriveAnyClass. A typical use-case of
+DeriveAnyClass is the following:
+
+  data MyDatatype = MyDatatype deriving (Generic, GEq)
+
+  class GEq (a :: *) where
+    geq :: a -> a -> Bool
+    default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
+    geq = geq' . from
+
+  class GEq' (f :: * -> *) where
+    geq' :: f a -> f a -> Bool
+
+  instance GEq' ... -- instances for each representation type
+
+We want to generate the following instance:
+
+  instance (Generic MyDatatype, GEq' (Rep MyDatatype)) => GEq MyDatatype
+
+But when solving this constraint, we won't have the type family instance
+`Rep MyDatatype` in the environment yet. We solve this problem by handling
+Generic differently from the other derivable classes. For Generic, we generate
+everything except the from/to method binds in advance, extend the local
+environment, and only then proceed to generate the rest of the derived
+instances.
+
+(With StandaloneDeriving and DeriveAnyClass, we just use whatever context the
+user provides.)
+
 -}
 
 ------------------------------------------------------------------
@@ -1578,15 +1663,18 @@ mkNewTypeEqn dflags overlap_mode tvs
         | might_derive_via_coercible -> bale_out (non_std $$ suggest_nd)
         | otherwise                  -> bale_out non_std
       -- CanDerive/DerivableViaInstance
-      _ -> do when (newtype_deriving && deriveAnyClass) $
+      DerivableViaInstance ->
+           do when (newtype_deriving && deriveAnyClass) $
                 addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled")
                                , ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ])
-              go_for_it
+              go_for_it False
+      CanDerive -> go_for_it True
   where
         newtype_deriving  = xopt Opt_GeneralizedNewtypeDeriving dflags
         deriveAnyClass    = xopt Opt_DeriveAnyClass             dflags
-        go_for_it         = mk_data_eqn overlap_mode tvs cls tycon tc_args
-                              rep_tycon rep_tc_args mtheta
+        go_for_it std_cls = mk_data_eqn overlap_mode std_cls tvs
+                                        cls cls_tys tycon tc_args
+                                        rep_tycon rep_tc_args mtheta
         bale_out    = bale_out' newtype_deriving
         bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
 
@@ -2037,13 +2125,11 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: CommonAuxiliaries
-        -> DerivSpec ThetaType
-        -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
-genInst comauxs
-        spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+genInst :: DerivSpec ThetaType
+        -> TcM (InstInfo RdrName, BagAuxBindSpec, Maybe Name)
+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
-                 , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
+                 , ds_cls = clas, ds_loc = loc })
   | is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
   = do { inst_spec <- newDerivClsInst theta spec
        ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty])
@@ -2061,9 +2147,7 @@ genInst comauxs
               -- See Note [Newtype deriving and unused constructors]
 
   | otherwise
-  = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
-                                        dfun_name rep_tycon
-                                        (lookup rep_tycon comauxs)
+  = do { (meth_binds, aux_binds) <- genAuxStuff loc clas rep_tycon
        ; inst_spec <- newDerivClsInst theta spec
        ; traceTc "newder" (ppr inst_spec)
        ; let inst_info = InstInfo { iSpec   = inst_spec
@@ -2073,27 +2157,44 @@ genInst comauxs
                                                 , ib_pragmas = []
                                                 , ib_extensions = []
                                                 , ib_derived = True } }
-       ; return ( inst_info, deriv_stuff, Nothing ) }
+       ; return ( inst_info, aux_binds, Nothing ) }
   where
     rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
-
-genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
-              -> Maybe CommonAuxiliary
+{-
+genDerivStuff :: GenericAuxiliaries
+              -> DerivSpec ()
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon comaux_maybe
+genDerivStuff genAuxs
+        spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
+                 , ds_newtype = is_newtype, ds_tys = tys
+                 , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
+  | is_newtype
+  = pprPanic "This shouldn't happen 1" (ppr (clas, rep_tycon))
+
   | let ck = classKey clas
   , ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
   = let gk = if ck == genClassKey then Gen0 else Gen1
         -- TODO NSF: correctly identify when we're building Both instead of One
-        Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
+        Just metaTyCons = lookup rep_tycon genAuxs -- well-guarded by genericAuxiliaries and genInst
     in do
-      (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name)
+      (binds, faminst) <- gen_Generic_binds gk rep_tycon metaTyCons (nameModule dfun_name)
       return (binds, unitBag (DerivFamInst faminst))
 
+  | otherwise
+  = pprPanic "This shouldn't happen 2" (ppr (clas, rep_tycon))
+-}
+genAuxStuff :: SrcSpan -> Class -> TyCon
+            -> TcM (LHsBinds RdrName, BagAuxBindSpec)
+genAuxStuff loc clas tycon
+  | let ck = classKey clas
+  , ck `elem` [genClassKey, gen1ClassKey]   -- Special case because monadic
+  = let gk = if ck == genClassKey then Gen0 else Gen1
+    in return (mkBindsRep gk tycon, emptyBag)
+
   | otherwise                      -- Non-monadic generators
   = do { dflags <- getDynFlags
        ; fix_env <- getDataConFixityFun tycon
-       ; return (genDerivedBinds dflags fix_env clas loc tycon) }
+       ; return $ genDerivedBinds dflags fix_env clas loc tycon }
 
 getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
 -- If the TyCon is locally defined, we want the local fixity env;
@@ -2125,13 +2226,13 @@ The 'deriving C' clause generates, in effect
   instance (C [a], Eq a) => C (N a) where
      f = coerce (f :: [a] -> [a])
 
-This generates a cast for each method, but allows the superclasse to
+This generates a cast for each method, but allows the superclasses to
 be worked out in the usual way.  In this case the superclass (Eq (N
 a)) will be solved by the explicit Eq (N a) instance.  We do *not*
 create the superclasses by casting the superclass dictionaries for the
 representation type.
 
-See the paper "Safe zero-cost coercions for Hsakell".
+See the paper "Safe zero-cost coercions for Haskell".
 
 
 ************************************************************************

compiler/typecheck/TcGenDeriv.hs

@@ -17,14 +17,14 @@ This is where we do all the grimy bindings' generation.
 
 module TcGenDeriv (
         BagDerivStuff, DerivStuff(..),
-
+        BagAuxBindSpec, AuxBindSpec(..),
         canDeriveAnyClass,
         genDerivedBinds,
         FFoldType(..), functorLikeTraverse,
         deepSubtypesContaining, foldDataConArgs,
         mkCoerceClassMethEqn,
         gen_Newtype_binds,
-        genAuxBinds,
+        genAuxBinds, splitDerivStuff,
         ordOpTbl, boxConTbl,
         mkRdrFunBind
     ) where
@@ -72,26 +72,25 @@ import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
 import Data.Maybe ( isNothing )
 
-type BagDerivStuff = Bag DerivStuff
+type BagAuxBindSpec = Bag AuxBindSpec
+type BagDerivStuff  = Bag DerivStuff
 
 data AuxBindSpec
-  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
-  | DerivTag2Con TyCon  -- ...ditto tag2Con
-  | DerivMaxTag  TyCon  -- ...and maxTag
+  = DerivCon2Tag     TyCon    -- The con2Tag for given TyCon
+  | DerivTag2Con     TyCon    -- ...ditto tag2Con
+  | DerivMaxTag      TyCon    -- ...and maxTag
+  | DerivDataTyCon   TyCon    -- SYB/Data's datatype info ($dT)
+  | DerivDataDataCon DataCon  -- SYB/Data's constructor info ($cT1 etc.)
   deriving( Eq )
   -- All these generate ZERO-BASED tag operations
   -- I.e first constructor has tag 0
 
-data DerivStuff     -- Please add this auxiliary stuff
-  = DerivAuxBind AuxBindSpec
-
-  -- Generics
-  | DerivTyCon TyCon                   -- New data types
-  | DerivFamInst FamInst               -- New type family instances
-
-  -- New top-level auxiliary bindings
-  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
-  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
+data DerivStuff
+  = -- For GHC.Generics
+    -- See Note [What deriving Generic/Generic1 generates] in TcGenGenerics
+    DerivFamInst FamInst         -- Rep/Rep1 type family instances (2)
+  | DerivTyCon TyCon             -- Data types for giving metadata instances (3)
+  | DerivInst (InstInfo RdrName) -- Datatype/Constructor/Selector instances (4)
 
 {-
 ************************************************************************
@@ -103,7 +102,7 @@ data DerivStuff     -- Please add this auxiliary stuff
 
 genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
                 -> ( LHsBinds RdrName  -- The method bindings of the instance declaration
-                   , BagDerivStuff)    -- Specifies extra top-level declarations needed
+                   , BagAuxBindSpec)   -- Specifies extra top-level declarations needed
                                        -- to support the instance declaration
 genDerivedBinds dflags fix_env clas loc tycon
   | Just gen_fn <- assocMaybe gen_list (getUnique clas)
@@ -117,7 +116,7 @@ genDerivedBinds dflags fix_env clas loc tycon
     (emptyBag, emptyBag)
 
   where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
+    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec))]
     gen_list = [ (eqClassKey,          gen_Eq_binds)
                , (typeableClassKey,    gen_Typeable_binds dflags)
                , (ordClassKey,         gen_Ord_binds)
@@ -126,7 +125,7 @@ genDerivedBinds dflags fix_env clas loc tycon
                , (ixClassKey,          gen_Ix_binds)
                , (showClassKey,        gen_Show_binds fix_env)
                , (readClassKey,        gen_Read_binds fix_env)
-               , (dataClassKey,        gen_Data_binds dflags)
+               , (dataClassKey,        gen_Data_binds)
                , (functorClassKey,     gen_Functor_binds)
                , (foldableClassKey,    gen_Foldable_binds)
                , (traversableClassKey, gen_Traversable_binds) ]
@@ -204,7 +203,7 @@ for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
 -}
 
-gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Eq_binds loc tycon
   = (method_binds, aux_binds)
   where
@@ -236,7 +235,7 @@ gen_Eq_binds loc tycon
                     (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
     aux_binds | no_tag_match_cons = emptyBag
-              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+              | otherwise         = unitBag $ DerivCon2Tag tycon
 
     method_binds = listToBag [eq_bind, ne_bind]
     eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
@@ -373,7 +372,7 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Ord_binds loc tycon
   | null tycon_data_cons        -- No data-cons => invoke bale-out case
   = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
@@ -381,7 +380,7 @@ gen_Ord_binds loc tycon
   = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
   where
     aux_binds | single_con_type = emptyBag
-              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+              | otherwise       = unitBag $ DerivCon2Tag tycon
 
         -- Note [Do not rely on compare]
     other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
@@ -594,7 +593,7 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 -}
 
-gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Enum_binds loc tycon
   = (method_binds, aux_binds)
   where
@@ -606,7 +605,7 @@ gen_Enum_binds loc tycon
                         enum_from_then,
                         from_enum
                     ]
-    aux_binds = listToBag $ map DerivAuxBind
+    aux_binds = listToBag
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
 
     occ_nm = getOccString tycon
@@ -674,7 +673,7 @@ gen_Enum_binds loc tycon
 ************************************************************************
 -}
 
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Bounded_binds loc tycon
   | isEnumerationTyCon tycon
   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
@@ -761,15 +760,14 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 -}
 
-gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 
 gen_Ix_binds loc tycon
   | isEnumerationTyCon tycon
   = ( enum_ixes
-    , listToBag $ map DerivAuxBind
-                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
+    , listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
   | otherwise
-  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+  = (single_con_ixes, unitBag (DerivCon2Tag tycon))
   where
     --------------------------------------------------------------
     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
@@ -950,7 +948,7 @@ 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 -> (LHsBinds RdrName, BagDerivStuff)
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 
 gen_Read_binds get_fixity loc tycon
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
@@ -1118,7 +1116,7 @@ Example
                     -- the most tightly-binding operator
 -}
 
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 
 gen_Show_binds get_fixity loc tycon
   = (listToBag [shows_prec, show_list], emptyBag)
@@ -1266,7 +1264,7 @@ We are passed the Typeable2 class as well as T
 -}
 
 gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
-                   -> (LHsBinds RdrName, BagDerivStuff)
+                   -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Typeable_binds dflags loc tycon
   = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat]
                 (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []])
@@ -1330,58 +1328,21 @@ we generate
     dataCast2 = gcast2   -- if T :: * -> * -> *
 -}
 
-gen_Data_binds :: DynFlags
-               -> SrcSpan
+gen_Data_binds :: SrcSpan
                -> TyCon                 -- For data families, this is the
                                         --  *representation* TyCon
                -> (LHsBinds RdrName,    -- The method bindings
-                   BagDerivStuff)       -- Auxiliary bindings
-gen_Data_binds dflags loc rep_tc
+                   BagAuxBindSpec)      -- Auxiliary bindings
+gen_Data_binds loc rep_tc
   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
      `unionBags` gcast_binds,
-                -- Auxiliary definitions: the data type and constructors
-     listToBag ( DerivHsBind (genDataTyCon)
-               : map (DerivHsBind . genDataDataCon) data_cons))
+      -- Auxiliary definitions: the data type and constructors
+     listToBag (DerivDataTyCon rep_tc : map DerivDataDataCon data_cons))
   where
     data_cons  = tyConDataCons rep_tc
     n_cons     = length data_cons
     one_constr = n_cons == 1
 
-    genDataTyCon :: (LHsBind RdrName, LSig RdrName)
-    genDataTyCon        --  $dT
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
-      where
-        rdr_name = mk_data_type_name rep_tc
-        sig_ty   = nlHsTyVar dataType_RDR
-        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
-        rhs = nlHsVar mkDataType_RDR
-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
-              `nlHsApp` nlList constrs
-
-    genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
-    genDataDataCon dc       --  $cT1 etc
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
-      where
-        rdr_name = mk_constr_name dc
-        sig_ty   = nlHsTyVar constr_RDR
-        rhs      = nlHsApps mkConstr_RDR constr_args
-
-        constr_args
-           = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
-           nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
-           nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
-               nlList  labels,                            -- Field labels
-           nlHsVar fixity]                                -- Fixity
-
-        labels   = map (nlHsLit . mkHsString . getOccString)
-                       (dataConFieldLabels dc)
-        dc_occ   = getOccName dc
-        is_infix = isDataSymOcc dc_occ
-        fixity | is_infix  = infix_RDR
-           | otherwise = prefix_RDR
-
         ------------ gfoldl
     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
 
@@ -1607,7 +1568,7 @@ so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expa
 It is better to produce too many lambdas than to eta expand, see ticket #7436.
 -}
 
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Functor_binds loc tycon
   = (unitBag fmap_bind, emptyBag)
   where
@@ -1797,7 +1758,7 @@ Note that the arguments to the real foldr function are the wrong way around,
 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
 -}
 
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Foldable_binds loc tycon
   = (listToBag [foldr_bind, foldMap_bind], emptyBag)
   where
@@ -1870,7 +1831,7 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
 instead of:         traverse f (T x y) = T x <$> f y
 -}
 
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagAuxBindSpec)
 gen_Traversable_binds loc tycon
   = (unitBag traverse_bind, emptyBag)
   where
@@ -2034,36 +1995,61 @@ genAuxBindSpec loc (DerivMaxTag tycon)
     max_tag =  case (tyConDataCons tycon) of
                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
-type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
-                              ( Bag (LHsBind RdrName, LSig RdrName)
-                                -- Extra bindings (used by Generic only)
-                              , Bag TyCon   -- Extra top-level datatypes
-                              , Bag (FamInst)           -- Extra family instances
-                              , Bag (InstInfo RdrName)) -- Extra instances
+genAuxBindSpec loc (DerivDataTyCon rep_tc) --  $dT
+      = (mkHsVarBind loc rdr_name rhs,
+         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
+      where
+        rdr_name = mk_data_type_name rep_tc
+        sig_ty   = nlHsTyVar dataType_RDR
+        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
+        rhs = nlHsVar mkDataType_RDR
+              -- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+              `nlHsApp` nlHsLit (mkHsString (showSDocSimple (ppr rep_tc)))
+              `nlHsApp` nlList constrs
 
-genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
-genAuxBinds loc b = genAuxBinds' b2 where
-  (b1,b2) = partitionBagWith splitDerivAuxBind b
-  splitDerivAuxBind (DerivAuxBind x) = Left x
-  splitDerivAuxBind  x               = Right x
+genAuxBindSpec loc (DerivDataDataCon dc)  -- $cT1 etc
+      = (mkHsVarBind loc rdr_name rhs,
+         L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
+      where
+        rdr_name = mk_constr_name dc
+        sig_ty   = nlHsTyVar constr_RDR
+        rhs      = nlHsApps mkConstr_RDR constr_args
 
-  rm_dups = foldrBag dup_check emptyBag
-  dup_check a b = if anyBag (== a) b then b else consBag a b
+        constr_args
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
+           nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
+           nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
+               nlList  labels,                            -- Field labels
+           nlHsVar fixity]                                -- Fixity
 
-  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
-  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
-                            , emptyBag, emptyBag, emptyBag)
+        labels   = map (nlHsLit . mkHsString . getOccString)
+                       (dataConFieldLabels dc)
+        dc_occ   = getOccName dc
+        is_infix = isDataSymOcc dc_occ
+        fixity | is_infix  = infix_RDR
+               | otherwise = prefix_RDR
+
+type SeparateBagsDerivStuff =
+  ( -- Extra bindings (used only by Generic)
+    -- See Note [What deriving Generic/Generic1 generates] in TcGenGenerics
+    Bag TyCon               -- Extra top-level datatypes
+  , Bag (FamInst)           -- Extra family instances
+  , Bag (InstInfo RdrName)) -- Extra instances
+
+splitDerivStuff :: BagDerivStuff -> SeparateBagsDerivStuff
+splitDerivStuff = foldrBag f (emptyBag, emptyBag, emptyBag) where
   f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
-  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
-  f (DerivHsBind  b) = add1 b
-  f (DerivTyCon   t) = add2 t
-  f (DerivFamInst t) = add3 t
-  f (DerivInst    i) = add4 i
-
-  add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
-  add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
-  add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
-  add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
+  f (DerivTyCon   t) = add1 t
+  f (DerivFamInst t) = add2 t
+  f (DerivInst    i) = add3 i
+  add1 x (a,b,c) = (x `consBag` a,b,c)
+  add2 x (a,b,c) = (a,x `consBag` b,c)
+  add3 x (a,b,c) = (a,b,x `consBag` c)
+
+genAuxBinds :: SrcSpan -> BagAuxBindSpec -> Bag (LHsBind RdrName, LSig RdrName)
+genAuxBinds loc = mapBag (genAuxBindSpec loc) . rm_dups where
+  rm_dups = foldrBag dup_check emptyBag
+  dup_check a b = if anyBag (== a) b then b else consBag a b
 
 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc

compiler/typecheck/TcGenGenerics.hs

@@ -11,8 +11,8 @@ The deriving code for the Generic class
 
 module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       GenericKind(..),
-                      MetaTyCons, genGenericMetaTyCons,
-                      gen_Generic_binds, get_gen1_constrained_tys) where
+                      MetaTyCons, genGenericMetaTyCons, mkBindsRep,
+                      tc_mkRepFamInst, get_gen1_constrained_tys) where
 
 import DynFlags
 import HsSyn
@@ -57,20 +57,72 @@ import Control.Monad (mplus,forM)
 *                                                                      *
 ************************************************************************
 
+Note [What deriving Generic/Generic1 generates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
 For the generic representation we need to generate:
-\begin{itemize}
-\item A Generic instance
-\item A Rep type instance
-\item Many auxiliary datatypes and instances for them (for the meta-information)
+1) A Generic/Generic1 instance
+2) A Rep/Rep1 type instance
+3) Many auxiliary datatypes (shared for both Generic and Generic1), and
+4) Instances for them (for the meta-information)
 \end{itemize}
--}
 
-gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
-                 -> TcM (LHsBinds RdrName, FamInst)
-gen_Generic_binds gk tc metaTyCons mod = do
-  repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod
-  return (mkBindsRep gk tc, repTyInsts)
+For example, given the following datatype:
+
+  data List a = Nil | Cons a (List a)
+
+We'll generate:
+
+1) A Generic and a Generic1 instance:
+
+  instance Generic (List a) where
+    from Nil = M1 (L1 (M1 U1))
+    from (Cons g1 g2) = M1 (R1 (M1 ((:*:) (M1 (K1 g1)) (M1 (K1 g2)))))
+    to (M1 (L1 (M1 U1))) = Nil
+    to (M1 (R1 (M1 ((:*:) (M1 (K1 g1)) (M1 (K1 g2)))))) = Cons g1 g2
+
+  instance Generic1 List where
+    from1 Nil = M1 (L1 (M1 U1))
+    from1 (Cons g1 g2) = M1 (R1 (M1 ((:*:) (M1 (Par1 g1)) (M1 (Rec1 g2)))))
+    to1 (M1 (L1 (M1 U1))) = Nil
+    to1 (M1 (R1 (M1 ((:*:) (M1 g1) (M1 g2))))) = Cons (unPar1 g1) (unRec1 g2)
+
+2) A Rep and Rep1 type family instance:
+
+    type Rep (List a) =
+      D1 D1List (C1 C1_0List U1
+             :+: C1 C1_1List (S1 S1_1_0List (Rec0 a)
+                          :*: S1 S1_1_1List (Rec0 (List a))))
+
+    type Rep1 List =
+      D1 D1List (C1 C1_0List U1
+             :+: C1 C1_1List (S1 S1_1_0List Par1
+                          :*: S1 S1_1_1List (Rec1 List)))
 
+3) Auxiliary, empty datatypes:
+
+    data D1List
+    data C1_0List
+    data C1_1List
+    data S1_1_0List
+    data S1_1_1List
+
+4) Instances for these datatypes:
+
+  instance Datatype D1List where
+    datatypeName _ = "List"
+    moduleName _   = "GenDerivOutput"
+    packageName _  = "main"
+
+  instance Constructor C1_0List where
+    conName _ = "Nil"
+
+  instance Constructor C1_1List where
+    conName _     = "Cons"
+    conIsRecord _ = True
+-}
+
+-- This function generates the empty datatypes and their instances (3 and 4)
 genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff)
 genGenericMetaTyCons tc mod =
   do  loc <- getSrcSpanM
@@ -428,9 +480,7 @@ gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
 gk2gkDC Gen0_   _ = Gen0_DC
 gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
 
-
-
--- Bindings for the Generic instance
+-- Bindings for the Generic instance (1)
 mkBindsRep :: GenericKind -> TyCon -> LHsBinds RdrName
 mkBindsRep gk tycon =
     unitBag (mkRdrFunBind (L loc from01_RDR) from_matches)
@@ -461,12 +511,13 @@ mkBindsRep gk tycon =
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepFamInsts :: GenericKind     -- Gen0 or Gen1
-               -> TyCon           -- The type to generate representation for
-               -> MetaTyCons      -- Metadata datatypes to refer to
-               -> Module          -- Used as the location of the new RepTy
-               -> TcM (FamInst)   -- Generated representation0 coercion
-tc_mkRepFamInsts gk tycon metaDts mod =
+-- This function generates the Rep/Rep type family instances (2)
+tc_mkRepFamInst :: GenericKind     -- Gen0 or Gen1
+                -> TyCon           -- The type to generate representation for
+                -> MetaTyCons      -- Metadata datatypes to refer to
+                -> Module          -- Used as the location of the new RepTy
+                -> TcM (FamInst)   -- Generated representation0 coercion
+tc_mkRepFamInst gk tycon metaDts mod =
        -- Consider the example input tycon `D`, where data D a b = D_ a
        -- Also consider `R:DInt`, where { data family D x y :: * -> *
        --                               ; data instance D Int a b = D_ a }

docs/users_guide/glasgow_exts.xml

@@ -1114,7 +1114,7 @@ on <literal>MkT</literal>. But the same pattern match also <emphasis>provides</e
 </para>
 <para>
 Exactly the same reasoning applies to <literal>ExNumPat</literal>:
-matching against <literal>ExNumPat</literal> <emphasis>requires</emphasis> 
+matching against <literal>ExNumPat</literal> <emphasis>requires</emphasis>
 the constraints <literal>(Num a, Eq a)</literal>, and <emphasis>provides</emphasis>
 the constraint <literal>(Show b)</literal>.
 </para>
@@ -4321,7 +4321,7 @@ the standard method is used or the one described here.)
 <para>
 With <option>-XDeriveAnyClass</option> you can derive any other class. The
 compiler will simply generate an empty instance. The instance context will be
-generated according to the same rules used when deriving <literal>Eq</literal>.
+generated by looking at the signatures for the default methods of the class.
 This is mostly useful in classes whose <link linkend="minimal-pragma">minimal
 set</link> is empty, and especially when writing
 <link linkend="generic-programming">generic functions</link>.
@@ -4974,7 +4974,7 @@ termination: see <xref linkend="instance-termination"/>.
 <para>
 Regardless of <option>-XFlexibleInstances</option> and <option>-XFlexibleContexts</option>,
 instance declarations must conform to some rules that ensure that instance resolution
-will terminate.  The restrictions can be lifted with <option>-XUndecidableInstances</option> 
+will terminate.  The restrictions can be lifted with <option>-XUndecidableInstances</option>
 (see <xref linkend="undecidable-instances"/>).
 </para>
 <para>
@@ -8638,7 +8638,7 @@ evaluated at runtime.. This behaviour follows that of the
 </listitem>
 
 <listitem><para>
-Unbound identifiers with the same name are never unified, even within the 
+Unbound identifiers with the same name are never unified, even within the
 same function, but shown individually.
 For example:
 <programlisting>

testsuite/tests/generics/GEq/GEq1A.hs

@@ -27,7 +27,7 @@ instance (GEq' a, GEq' b) => GEq' (a :*: b) where
   geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
 
 
-class GEq a where 
+class GEq a where
   geq :: a -> a -> Bool
   default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
   geq x y = geq' (from x) (from y)

testsuite/tests/generics/GenDerivOutput.stderr

@@ -133,20 +133,35 @@ Generic representation:
     GenDerivOutput.S1_1_1Rose
   
   Representation types:
-    type GHC.Generics.Rep (GenDerivOutput.List a) = GHC.Generics.D1
-                                                      GenDerivOutput.D1List
+    type GHC.Generics.Rep1 GenDerivOutput.Rose = GHC.Generics.D1
+                                                   GenDerivOutput.D1Rose
+                                                   (GHC.Generics.C1
+                                                      GenDerivOutput.C1_0Rose GHC.Generics.U1
+                                                    GHC.Generics.:+: GHC.Generics.C1
+                                                                       GenDerivOutput.C1_1Rose
+                                                                       (GHC.Generics.S1
+                                                                          GHC.Generics.NoSelector
+                                                                          GHC.Generics.Par1
+                                                                        GHC.Generics.:*: GHC.Generics.S1
+                                                                                           GHC.Generics.NoSelector
+                                                                                           (GenDerivOutput.List
+                                                                                            GHC.Generics.:.: GHC.Generics.Rec1
+                                                                                                               GenDerivOutput.Rose)))
+    type GHC.Generics.Rep (GenDerivOutput.Rose a) = GHC.Generics.D1
+                                                      GenDerivOutput.D1Rose
                                                       (GHC.Generics.C1
-                                                         GenDerivOutput.C1_0List GHC.Generics.U1
+                                                         GenDerivOutput.C1_0Rose GHC.Generics.U1
                                                        GHC.Generics.:+: GHC.Generics.C1
-                                                                          GenDerivOutput.C1_1List
+                                                                          GenDerivOutput.C1_1Rose
                                                                           (GHC.Generics.S1
-                                                                             GenDerivOutput.S1_1_0List
+                                                                             GHC.Generics.NoSelector
                                                                              (GHC.Generics.Rec0 a)
                                                                            GHC.Generics.:*: GHC.Generics.S1
-                                                                                              GenDerivOutput.S1_1_1List
+                                                                                              GHC.Generics.NoSelector
                                                                                               (GHC.Generics.Rec0
                                                                                                  (GenDerivOutput.List
-                                                                                                    a))))
+                                                                                                    (GenDerivOutput.Rose
+                                                                                                       a)))))
     type GHC.Generics.Rep1 GenDerivOutput.List = GHC.Generics.D1
                                                    GenDerivOutput.D1List
                                                    (GHC.Generics.C1
@@ -160,34 +175,19 @@ Generic representation:
                                                                                            GenDerivOutput.S1_1_1List
                                                                                            (GHC.Generics.Rec1
                                                                                               GenDerivOutput.List)))
-    type GHC.Generics.Rep (GenDerivOutput.Rose a) = GHC.Generics.D1
-                                                      GenDerivOutput.D1Rose
+    type GHC.Generics.Rep (GenDerivOutput.List a) = GHC.Generics.D1
+                                                      GenDerivOutput.D1List
                                                       (GHC.Generics.C1
-                                                         GenDerivOutput.C1_0Rose GHC.Generics.U1
+                                                         GenDerivOutput.C1_0List GHC.Generics.U1
                                                        GHC.Generics.:+: GHC.Generics.C1
-                                                                          GenDerivOutput.C1_1Rose
+                                                                          GenDerivOutput.C1_1List
                                                                           (GHC.Generics.S1
-                                                                             GHC.Generics.NoSelector
+                                                                             GenDerivOutput.S1_1_0List
                                                                              (GHC.Generics.Rec0 a)
                                                                            GHC.Generics.:*: GHC.Generics.S1
-                                                                                              GHC.Generics.NoSelector
+                                                                                              GenDerivOutput.S1_1_1List
                                                                                               (GHC.Generics.Rec0
                                                                                                  (GenDerivOutput.List
-                                                                                                    (GenDerivOutput.Rose
-                                                                                                       a)))))
-    type GHC.Generics.Rep1 GenDerivOutput.Rose = GHC.Generics.D1
-                                                   GenDerivOutput.D1Rose
-                                                   (GHC.Generics.C1
-                                                      GenDerivOutput.C1_0Rose GHC.Generics.U1
-                                                    GHC.Generics.:+: GHC.Generics.C1
-                                                                       GenDerivOutput.C1_1Rose
-                                                                       (GHC.Generics.S1
-                                                                          GHC.Generics.NoSelector
-                                                                          GHC.Generics.Par1
-                                                                        GHC.Generics.:*: GHC.Generics.S1
-                                                                                           GHC.Generics.NoSelector
-                                                                                           (GenDerivOutput.List
-                                                                                            GHC.Generics.:.: GHC.Generics.Rec1
-                                                                                                               GenDerivOutput.Rose)))
+                                                                                                    a))))
 
 

testsuite/tests/generics/GenDerivOutput1_1.stderr

@@ -251,31 +251,18 @@ Generic representation:
     CanDoRep1_1.S1_1_1Dd
   
   Representation types:
-    type GHC.Generics.Rep1 CanDoRep1_1.Dd = GHC.Generics.D1
-                                              CanDoRep1_1.D1Dd
-                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1
+    type GHC.Generics.Rep1 CanDoRep1_1.Db = GHC.Generics.D1
+                                              CanDoRep1_1.D1Db
+                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1
                                                GHC.Generics.:+: GHC.Generics.C1
-                                                                  CanDoRep1_1.C1_1Dd
+                                                                  CanDoRep1_1.C1_1Db
                                                                   (GHC.Generics.S1
-                                                                     CanDoRep1_1.S1_1_0Dd
+                                                                     CanDoRep1_1.S1_1_0Db
                                                                      GHC.Generics.Par1
                                                                    GHC.Generics.:*: GHC.Generics.S1
-                                                                                      CanDoRep1_1.S1_1_1Dd
+                                                                                      CanDoRep1_1.S1_1_1Db
                                                                                       (GHC.Generics.Rec1
-                                                                                         CanDoRep1_1.Dd)))
-    type GHC.Generics.Rep (CanDoRep1_1.Dd a) = GHC.Generics.D1
-                                                 CanDoRep1_1.D1Dd
-                                                 (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1
-                                                  GHC.Generics.:+: GHC.Generics.C1
-                                                                     CanDoRep1_1.C1_1Dd
-                                                                     (GHC.Generics.S1
-                                                                        CanDoRep1_1.S1_1_0Dd
-                                                                        (GHC.Generics.Rec0 a)
-                                                                      GHC.Generics.:*: GHC.Generics.S1
-                                                                                         CanDoRep1_1.S1_1_1Dd
-                                                                                         (GHC.Generics.Rec0
-                                                                                            (CanDoRep1_1.Dd
-                                                                                               a))))
+                                                                                         CanDoRep1_1.Db)))
     type GHC.Generics.Rep (CanDoRep1_1.Dc a) = GHC.Generics.D1
                                                  CanDoRep1_1.D1Dc
                                                  (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1
@@ -289,43 +276,43 @@ Generic representation:
                                                                                          (GHC.Generics.Rec0
                                                                                             (CanDoRep1_1.Dc
                                                                                                a))))
-    type GHC.Generics.Rep1 CanDoRep1_1.Db = GHC.Generics.D1
-                                              CanDoRep1_1.D1Db
-                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1
-                                               GHC.Generics.:+: GHC.Generics.C1
-                                                                  CanDoRep1_1.C1_1Db
-                                                                  (GHC.Generics.S1
-                                                                     CanDoRep1_1.S1_1_0Db
-                                                                     GHC.Generics.Par1
-                                                                   GHC.Generics.:*: GHC.Generics.S1
-                                                                                      CanDoRep1_1.S1_1_1Db
-                                                                                      (GHC.Generics.Rec1
-                                                                                         CanDoRep1_1.Db)))
-    type GHC.Generics.Rep (CanDoRep1_1.Da a) = GHC.Generics.D1
-                                                 CanDoRep1_1.D1Da
-                                                 (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1
+    type GHC.Generics.Rep (CanDoRep1_1.Dd a) = GHC.Generics.D1
+                                                 CanDoRep1_1.D1Dd
+                                                 (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1
                                                   GHC.Generics.:+: GHC.Generics.C1
-                                                                     CanDoRep1_1.C1_1Da
+                                                                     CanDoRep1_1.C1_1Dd
                                                                      (GHC.Generics.S1
-                                                                        CanDoRep1_1.S1_1_0Da
+                                                                        CanDoRep1_1.S1_1_0Dd
                                                                         (GHC.Generics.Rec0 a)
                                                                       GHC.Generics.:*: GHC.Generics.S1
-                                                                                         CanDoRep1_1.S1_1_1Da
+                                                                                         CanDoRep1_1.S1_1_1Dd
                                                                                          (GHC.Generics.Rec0
-                                                                                            (CanDoRep1_1.Da
+                                                                                            (CanDoRep1_1.Dd
                                                                                                a))))
-    type GHC.Generics.Rep1 CanDoRep1_1.Da = GHC.Generics.D1
-                                              CanDoRep1_1.D1Da
-                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1
+    type GHC.Generics.Rep1 CanDoRep1_1.Dd = GHC.Generics.D1
+                                              CanDoRep1_1.D1Dd
+                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Dd GHC.Generics.U1
                                                GHC.Generics.:+: GHC.Generics.C1
-                                                                  CanDoRep1_1.C1_1Da
+                                                                  CanDoRep1_1.C1_1Dd
                                                                   (GHC.Generics.S1
-                                                                     CanDoRep1_1.S1_1_0Da
+                                                                     CanDoRep1_1.S1_1_0Dd
                                                                      GHC.Generics.Par1
                                                                    GHC.Generics.:*: GHC.Generics.S1
-                                                                                      CanDoRep1_1.S1_1_1Da
+                                                                                      CanDoRep1_1.S1_1_1Dd
                                                                                       (GHC.Generics.Rec1
-                                                                                         CanDoRep1_1.Da)))
+                                                                                         CanDoRep1_1.Dd)))
+    type GHC.Generics.Rep1 CanDoRep1_1.Dc = GHC.Generics.D1
+                                              CanDoRep1_1.D1Dc
+                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1
+                                               GHC.Generics.:+: GHC.Generics.C1
+                                                                  CanDoRep1_1.C1_1Dc
+                                                                  (GHC.Generics.S1
+                                                                     CanDoRep1_1.S1_1_0Dc
+                                                                     GHC.Generics.Par1
+                                                                   GHC.Generics.:*: GHC.Generics.S1
+                                                                                      CanDoRep1_1.S1_1_1Dc
+                                                                                      (GHC.Generics.Rec1
+                                                                                         CanDoRep1_1.Dc)))
     type GHC.Generics.Rep (CanDoRep1_1.Db a) = GHC.Generics.D1
                                                  CanDoRep1_1.D1Db
                                                  (GHC.Generics.C1 CanDoRep1_1.C1_0Db GHC.Generics.U1
@@ -339,17 +326,30 @@ Generic representation:
                                                                                          (GHC.Generics.Rec0
                                                                                             (CanDoRep1_1.Db
                                                                                                a))))
-    type GHC.Generics.Rep1 CanDoRep1_1.Dc = GHC.Generics.D1
-                                              CanDoRep1_1.D1Dc
-                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Dc GHC.Generics.U1
+    type GHC.Generics.Rep1 CanDoRep1_1.Da = GHC.Generics.D1
+                                              CanDoRep1_1.D1Da
+                                              (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1
                                                GHC.Generics.:+: GHC.Generics.C1
-                                                                  CanDoRep1_1.C1_1Dc
+                                                                  CanDoRep1_1.C1_1Da
                                                                   (GHC.Generics.S1
-                                                                     CanDoRep1_1.S1_1_0Dc
+                                                                     CanDoRep1_1.S1_1_0Da
                                                                      GHC.Generics.Par1
                                                                    GHC.Generics.:*: GHC.Generics.S1
-                                                                                      CanDoRep1_1.S1_1_1Dc
+                                                                                      CanDoRep1_1.S1_1_1Da
                                                                                       (GHC.Generics.Rec1
-                                                                                         CanDoRep1_1.Dc)))
+                                                                                         CanDoRep1_1.Da)))
+    type GHC.Generics.Rep (CanDoRep1_1.Da a) = GHC.Generics.D1
+                                                 CanDoRep1_1.D1Da
+                                                 (GHC.Generics.C1 CanDoRep1_1.C1_0Da GHC.Generics.U1
+                                                  GHC.Generics.:+: GHC.Generics.C1
+                                                                     CanDoRep1_1.C1_1Da
+                                                                     (GHC.Generics.S1
+                                                                        CanDoRep1_1.S1_1_0Da
+                                                                        (GHC.Generics.Rec0 a)
+                                                                      GHC.Generics.:*: GHC.Generics.S1
+                                                                                         CanDoRep1_1.S1_1_1Da
+                                                                                         (GHC.Generics.Rec0
+                                                                                            (CanDoRep1_1.Da
+                                                                                               a))))
 
 

testsuite/tests/generics/T5462Yes1.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE DefaultSignatures      #-}
 {-# LANGUAGE StandaloneDeriving     #-}
 {-# LANGUAGE UndecidableInstances   #-}
-{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveAnyClass         #-}
 
 module Main where
 
@@ -13,9 +13,10 @@ import GHC.Generics hiding (C, C1, D)
 import GEq1A
 import Enum
 import GFunctor
+import GShow
 
 data A = A1
-  deriving (Show, Generic, GEq, GEnum)
+  deriving (Show, Generic, GEq, GEnum, GShow)
 
 data B a = B1 | B2 a (B a)
   deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)
@@ -34,6 +35,7 @@ data E f a = E1 (f a)
 main = print (
                geq A1 A1
              , take 10 (genum :: [A])
+             , gshow A1
 
              , geq (B2 A1 B1) B1
              , gmap (++ "lo") (B2 "hel" B1)

testsuite/tests/generics/T5462Yes1.stdout

-(True,[A1],False,B2 "hello" B1,[B1,B2 A1 B1,B2 A1 (B2 A1 B1)],False,C2 "hello" C1,True,E1 ["hello"])
+(True,[A1],"A1",False,B2 "hello" B1,[B1,B2 A1 B1,B2 A1 (B2 A1 B1)],False,C2 "hello" C1,True,E1 ["hello"])

testsuite/tests/generics/all.T

@@ -20,7 +20,7 @@ test('GenCannotDoRep1_7', normal, compile_fail, [''])
 test('GenCannotDoRep1_8', normal, compile_fail, [''])
 
 test('T5462Yes1', extra_clean(['T5462Yes1/GFunctor.hi'])
-    , multimod_compile_and_run, ['T5462Yes1', '-iGEq -iGEnum -iGFunctor -outputdir=out_T5462Yes1'])
+    , multimod_compile_and_run, ['T5462Yes1', '-iGEq -iGEnum -iGFunctor -iGShow -outputdir=out_T5462Yes1'])
 test('T5462Yes2', extra_clean(['T5462Yes2/GFunctor.hi'])
     , multimod_compile_and_run, ['T5462Yes2', '-iGFunctor -outputdir=out_T5462Yes2'])
 test('T5462No1', extra_clean(['T5462No1/GFunctor.hi'])
@@ -34,7 +34,7 @@ test('GenDerivOutput1_1', normal, compile, ['-dsuppress-uniques'])
 
 test('T7878', extra_clean(['T7878A.o'     ,'T7878A.hi'
                           ,'T7878A.o-boot','T7878A.hi-boot'
-                          ,'T7878B.o'     ,'T7878B.hi']), 
+                          ,'T7878B.o'     ,'T7878B.hi']),
               multimod_compile, ['T7878', '-v0'])
 
 test('T8468', normal, compile_fail, [''])

testsuite/tests/typecheck/should_compile/T9968.hs

+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE PolyKinds                  #-}
+
+module T9968 where
+
+import GHC.Generics ( Generic(..), Generic1(..), Rep, M1(..) )
+
+
+data D1 = D11
+  deriving (C1, C8)
+
+newtype D2 = D21 Int
+  deriving (C1, C8)
+
+newtype D3 a = D31 a
+  deriving (Show, Foldable, C1, C2, C3 a, C5 Int, C8)
+
+data D4 a = D41
+  deriving (Foldable, C2)
+
+data D5 a b = D51 a | D52 b
+  deriving (C9)
+
+data D6 f a = D61 (f a)
+  deriving (C1, C8)
+
+data D7 h f = D71 (h f) (f Int)
+  deriving (C1, C3 Int, C4)
+
+instance Show (D7 h f) where show = undefined
+
+data Proxy (t :: k) = Proxy
+  deriving (Foldable, C1, C2, C8)
+
+
+class C1 a where
+  c11 :: a -> Int
+  c11 = undefined
+
+class Foldable f => C2 f where
+  c21 :: (Show a) => f a -> String
+  c21 = foldMap show
+
+class C3 a b where
+  c31 :: Read c => a -> b -> c
+  default c31 :: (Show a, Show b, Read c) => a -> b -> c
+  c31 a b = read (show a ++ show b)
+
+class C4 h where
+  c41 :: (f a -> f a) -> h f -> Int
+  c41 = undefined
+
+class C5 a f where
+  c51 :: f a -> Int
+  c51 = undefined
+
+class C6 a where
+  c61 :: a -> Int
+  default c61 :: (Generic a, C7 (Rep a)) => a -> Int
+  c61 = c71 . from
+
+-- trivial generic function that always returns 0
+class C7 f where c71 :: f p -> Int
+instance C7 (M1 i c f) where c71 _ = 0
+
+class C8 (a :: k) where
+  c81 :: Proxy a -> Int
+  c81 _ = 0
+
+class C9 (h :: * -> * -> *) where
+  c91 :: h a b -> Int
+  c91 _ = 0

testsuite/tests/typecheck/should_compile/all.T

@@ -254,9 +254,9 @@ test('tc236', normal, compile, [''])
 test('tc237', normal, compile, [''])
 test('tc238', normal, compile, [''])
 
-test('tc239', extra_clean(['Tc239_Help.hi', 'Tc239_Help.o']), 
+test('tc239', extra_clean(['Tc239_Help.hi', 'Tc239_Help.o']),
      multimod_compile, ['tc239', '-v0'])
-     
+
 test('tc240', normal, compile, [''])
 test('tc241', normal, compile, [''])
 test('tc242', normal, compile, [''])
@@ -278,13 +278,13 @@ test('FD4', normal, compile, [''])
 test('faxen', normal, compile, [''])
 test('T1495', normal, compile, [''])
 test('T2045', normal, compile, [''])   # Needs -fhpc
-test('T2478', normal, compile, ['']) 
-test('T2433', extra_clean(['T2433_Help.hi', 'T2433_Help.o']), 
+test('T2478', normal, compile, [''])
+test('T2433', extra_clean(['T2433_Help.hi', 'T2433_Help.o']),
      multimod_compile, ['T2433', '-v0'])
-test('T2494', normal, compile_fail, ['']) 
-test('T2494-2', normal, compile, ['']) 
-test('T2497', normal, compile, ['']) 
-     
+test('T2494', normal, compile_fail, [''])
+test('T2494-2', normal, compile, [''])
+test('T2497', normal, compile, [''])
+
 
 # Omitting temporarily
 test('syn-perf', normal, compile, ['-fcontext-stack=30'])
@@ -332,7 +332,7 @@ test('T4498', normal, compile, [''])
 test('T4524', normal, compile, [''])
 test('T4917', normal, compile, [''])
 
-test('T4912', extra_clean(['T4912a.hi', 'T4912a.o']), 
+test('T4912', extra_clean(['T4912a.hi', 'T4912a.o']),
      multimod_compile, ['T4912', '-v0'])
 
 test('T4952', normal, compile, [''])
@@ -438,6 +438,7 @@ test('T7643', normal, compile, [''])
 test('T9834', normal, compile, [''])
 test('T9892', normal, compile, [''])
 test('T9939', normal, compile, [''])
+test('T9968', normal, compile, [''])
 test('T9973', normal, compile, [''])
 test('T9971', normal, compile, [''])
 test('T9999', normal, compile, [''])