    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    -}

    {-# LANGUAGE TypeFamilies #-}

    -- | Error-checking and other utilities for @deriving@ clauses or declarations.
    module GHC.Tc.Deriv.Utils (
            DerivM, DerivEnv(..),
            DerivSpec(..), pprDerivSpec, DerivInstTys(..),
            DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
            isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
            DerivContext(..), OriginativeDerivStatus(..),
            isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
            PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
            mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
            checkOriginativeSideConditions, hasStockDeriving,
            canDeriveAnyClass,
            std_class_via_coercible, non_coercible_class,
            newDerivClsInst, extendLocalInstEnv
        ) where

    import GHC.Prelude

    import GHC.Data.Bag
    import GHC.Types.Basic
    import GHC.Core.Class
    import GHC.Core.DataCon
    import GHC.Driver.Session
    import GHC.Utils.Error
    import GHC.Types.Fixity.Env (lookupFixity)
    import GHC.Hs
    import GHC.Tc.Utils.Instantiate
    import GHC.Core.InstEnv
    import GHC.Iface.Load   (loadInterfaceForName)
    import GHC.Unit.Module (getModule)
    import GHC.Unit.Module.ModIface (mi_fix)
    import GHC.Types.Name
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Builtin.Names
    import GHC.Types.SrcLoc
    import GHC.Tc.Deriv.Generate
    import GHC.Tc.Deriv.Functor
    import GHC.Tc.Deriv.Generics
    import GHC.Tc.Types.Origin
    import GHC.Tc.Utils.Monad
    import GHC.Tc.Utils.TcType
    import GHC.Builtin.Names.TH (liftClassKey)
    import GHC.Core.TyCon
    import GHC.Core.Multiplicity
    import GHC.Core.TyCo.Ppr (pprSourceTyCon)
    import GHC.Core.Type
    import GHC.Utils.Misc
    import GHC.Types.Var.Set

    import Control.Monad.Trans.Reader
    import Data.Maybe
    import qualified GHC.LanguageExtensions as LangExt
    import GHC.Data.List.SetOps (assocMaybe)

    -- | To avoid having to manually plumb everything in 'DerivEnv' throughout
    -- various functions in "GHC.Tc.Deriv" and "GHC.Tc.Deriv.Infer", we use 'DerivM', which
    -- is a simple reader around 'TcRn'.
    type DerivM = ReaderT DerivEnv TcRn

    -- | Is GHC processing a standalone deriving declaration?
    isStandaloneDeriv :: DerivM Bool
    isStandaloneDeriv :: DerivM Bool
    isStandaloneDeriv = (DerivEnv -> Bool) -> DerivM Bool
    forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
    asks (DerivContext -> Bool
    go (DerivContext -> Bool)
    -> (DerivEnv -> DerivContext) -> DerivEnv -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DerivEnv -> DerivContext
    denv_ctxt)
      where
        go :: DerivContext -> Bool
        go :: DerivContext -> Bool
    go (InferContext Maybe SrcSpan
    wildcard) = Maybe SrcSpan -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe SrcSpan
    wildcard
        go (SupplyContext {})      = Bool
    True

    -- | Is GHC processing a standalone deriving declaration with an
    -- extra-constraints wildcard as the context?
    -- (e.g., @deriving instance _ => Eq (Foo a)@)
    isStandaloneWildcardDeriv :: DerivM Bool
    isStandaloneWildcardDeriv :: DerivM Bool
    isStandaloneWildcardDeriv = (DerivEnv -> Bool) -> DerivM Bool
    forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
    asks (DerivContext -> Bool
    go (DerivContext -> Bool)
    -> (DerivEnv -> DerivContext) -> DerivEnv -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DerivEnv -> DerivContext
    denv_ctxt)
      where
        go :: DerivContext -> Bool
        go :: DerivContext -> Bool
    go (InferContext Maybe SrcSpan
    wildcard) = Maybe SrcSpan -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe SrcSpan
    wildcard
        go (SupplyContext {})      = Bool
    False

    -- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
    -- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
    mkDerivOrigin :: Bool -> CtOrigin
    mkDerivOrigin :: Bool -> CtOrigin
    mkDerivOrigin Bool
    standalone_wildcard
      | Bool
    standalone_wildcard = CtOrigin
    StandAloneDerivOrigin
      | Bool
    otherwise           = CtOrigin
    DerivClauseOrigin

    -- | Contains all of the information known about a derived instance when
    -- determining what its @EarlyDerivSpec@ should be.
    -- See @Note [DerivEnv and DerivSpecMechanism]@.
    data DerivEnv = DerivEnv
      { DerivEnv -> Maybe OverlapMode
    denv_overlap_mode :: Maybe OverlapMode
        -- ^ Is this an overlapping instance?
      , DerivEnv -> [TyVar]
    denv_tvs          :: [TyVar]
        -- ^ Universally quantified type variables in the instance
      , DerivEnv -> Class
    denv_cls          :: Class
        -- ^ Class for which we need to derive an instance
      , DerivEnv -> [Type]
    denv_inst_tys     :: [Type]
        -- ^ All arguments to 'denv_cls' in the derived instance.
      , DerivEnv -> DerivContext
    denv_ctxt         :: DerivContext
        -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
        --   context of the instance).
        --   'InferContext' for @deriving@ clauses, or for standalone deriving that
        --   uses a wildcard constraint.
        --   See @Note [Inferring the instance context]@.
      , DerivEnv -> Maybe (DerivStrategy GhcTc)
    denv_strat        :: Maybe (DerivStrategy GhcTc)
        -- ^ 'Just' if user requests a particular deriving strategy.
        --   Otherwise, 'Nothing'.
      }

    instance Outputable DerivEnv where
      ppr :: DerivEnv -> SDoc
    ppr (DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
    denv_overlap_mode = Maybe OverlapMode
    overlap_mode
                    , denv_tvs :: DerivEnv -> [TyVar]
    denv_tvs          = [TyVar]
    tvs
                    , denv_cls :: DerivEnv -> Class
    denv_cls          = Class
    cls
                    , denv_inst_tys :: DerivEnv -> [Type]
    denv_inst_tys     = [Type]
    inst_tys
                    , denv_ctxt :: DerivEnv -> DerivContext
    denv_ctxt         = DerivContext
    ctxt
                    , denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
    denv_strat        = Maybe (DerivStrategy GhcTc)
    mb_strat })
        = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "DerivEnv")
             Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "denv_overlap_mode" SDoc -> SDoc -> SDoc
    <+> Maybe OverlapMode -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe OverlapMode
    overlap_mode
                     , String -> SDoc
    text String
    "denv_tvs"          SDoc -> SDoc -> SDoc
    <+> [TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    tvs
                     , String -> SDoc
    text String
    "denv_cls"          SDoc -> SDoc -> SDoc
    <+> Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    cls
                     , String -> SDoc
    text String
    "denv_inst_tys"     SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    inst_tys
                     , String -> SDoc
    text String
    "denv_ctxt"         SDoc -> SDoc -> SDoc
    <+> DerivContext -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DerivContext
    ctxt
                     , String -> SDoc
    text String
    "denv_strat"        SDoc -> SDoc -> SDoc
    <+> Maybe (DerivStrategy GhcTc) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe (DerivStrategy GhcTc)
    mb_strat ])

    data DerivSpec theta = DS { forall theta. DerivSpec theta -> SrcSpan
    ds_loc                 :: SrcSpan
                              , forall theta. DerivSpec theta -> Name
    ds_name                :: Name         -- DFun name
                              , forall theta. DerivSpec theta -> [TyVar]
    ds_tvs                 :: [TyVar]
                              , forall theta. DerivSpec theta -> theta
    ds_theta               :: theta
                              , forall theta. DerivSpec theta -> Class
    ds_cls                 :: Class
                              , forall theta. DerivSpec theta -> [Type]
    ds_tys                 :: [Type]
                              , forall theta. DerivSpec theta -> Maybe OverlapMode
    ds_overlap             :: Maybe OverlapMode
                              , forall theta. DerivSpec theta -> Maybe SrcSpan
    ds_standalone_wildcard :: Maybe SrcSpan
                                  -- See Note [Inferring the instance context]
                                  -- in GHC.Tc.Deriv.Infer
                              , forall theta. DerivSpec theta -> DerivSpecMechanism
    ds_mechanism           :: DerivSpecMechanism }
            -- This spec implies a dfun declaration of the form
            --       df :: forall tvs. theta => C tys
            -- The Name is the name for the DFun we'll build
            -- The tyvars bind all the variables in the theta

            -- the theta is either the given and final theta, in standalone deriving,
            -- or the not-yet-simplified list of constraints together with their origin

            -- ds_mechanism specifies the means by which GHC derives the instance.
            -- See Note [Deriving strategies] in GHC.Tc.Deriv

    {-
    Example:

         newtype instance T [a] = MkT (Tree a) deriving( C s )
    ==>
         axiom T [a] = :RTList a
         axiom :RTList a = Tree a

         DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
            , ds_mechanism = DerivSpecNewtype (Tree a) }
    -}

    pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
    pprDerivSpec :: forall theta. Outputable theta => DerivSpec theta -> SDoc
    pprDerivSpec (DS { ds_loc :: forall theta. DerivSpec theta -> SrcSpan
    ds_loc = SrcSpan
    l, ds_name :: forall theta. DerivSpec theta -> Name
    ds_name = Name
    n, ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
    ds_tvs = [TyVar]
    tvs, ds_cls :: forall theta. DerivSpec theta -> Class
    ds_cls = Class
    c,
                       ds_tys :: forall theta. DerivSpec theta -> [Type]
    ds_tys = [Type]
    tys, ds_theta :: forall theta. DerivSpec theta -> theta
    ds_theta = theta
    rhs,
                       ds_standalone_wildcard :: forall theta. DerivSpec theta -> Maybe SrcSpan
    ds_standalone_wildcard = Maybe SrcSpan
    wildcard, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
    ds_mechanism = DerivSpecMechanism
    mech })
      = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "DerivSpec")
           Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "ds_loc                  =" SDoc -> SDoc -> SDoc
    <+> SrcSpan -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr SrcSpan
    l
                   , String -> SDoc
    text String
    "ds_name                 =" SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    n
                   , String -> SDoc
    text String
    "ds_tvs                  =" SDoc -> SDoc -> SDoc
    <+> [TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    tvs
                   , String -> SDoc
    text String
    "ds_cls                  =" SDoc -> SDoc -> SDoc
    <+> Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    c
                   , String -> SDoc
    text String
    "ds_tys                  =" SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    tys
                   , String -> SDoc
    text String
    "ds_theta                =" SDoc -> SDoc -> SDoc
    <+> theta -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr theta
    rhs
                   , String -> SDoc
    text String
    "ds_standalone_wildcard  =" SDoc -> SDoc -> SDoc
    <+> Maybe SrcSpan -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe SrcSpan
    wildcard
                   , String -> SDoc
    text String
    "ds_mechanism            =" SDoc -> SDoc -> SDoc
    <+> DerivSpecMechanism -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DerivSpecMechanism
    mech ])

    instance Outputable theta => Outputable (DerivSpec theta) where
      ppr :: DerivSpec theta -> SDoc
    ppr = DerivSpec theta -> SDoc
    forall theta. Outputable theta => DerivSpec theta -> SDoc
    pprDerivSpec

    -- | Information about the arguments to the class in a stock- or
    -- newtype-derived instance.
    -- See @Note [DerivEnv and DerivSpecMechanism]@.
    data DerivInstTys = DerivInstTys
      { DerivInstTys -> [Type]
    dit_cls_tys     :: [Type]
        -- ^ Other arguments to the class except the last
      , DerivInstTys -> TyCon
    dit_tc          :: TyCon
        -- ^ Type constructor for which the instance is requested
        --   (last arguments to the type class)
      , DerivInstTys -> [Type]
    dit_tc_args     :: [Type]
        -- ^ Arguments to the type constructor
      , DerivInstTys -> TyCon
    dit_rep_tc      :: TyCon
        -- ^ The representation tycon for 'dit_tc'
        --   (for data family instances). Otherwise the same as 'dit_tc'.
      , DerivInstTys -> [Type]
    dit_rep_tc_args :: [Type]
        -- ^ The representation types for 'dit_tc_args'
        --   (for data family instances). Otherwise the same as 'dit_tc_args'.
      }

    instance Outputable DerivInstTys where
      ppr :: DerivInstTys -> SDoc
    ppr (DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
    dit_cls_tys = [Type]
    cls_tys, dit_tc :: DerivInstTys -> TyCon
    dit_tc = TyCon
    tc, dit_tc_args :: DerivInstTys -> [Type]
    dit_tc_args = [Type]
    tc_args
                        , dit_rep_tc :: DerivInstTys -> TyCon
    dit_rep_tc = TyCon
    rep_tc, dit_rep_tc_args :: DerivInstTys -> [Type]
    dit_rep_tc_args = [Type]
    rep_tc_args })
        = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "DITTyConHead")
             Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "dit_cls_tys"     SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    cls_tys
                     , String -> SDoc
    text String
    "dit_tc"          SDoc -> SDoc -> SDoc
    <+> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc
                     , String -> SDoc
    text String
    "dit_tc_args"     SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    tc_args
                     , String -> SDoc
    text String
    "dit_rep_tc"      SDoc -> SDoc -> SDoc
    <+> TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    rep_tc
                     , String -> SDoc
    text String
    "dit_rep_tc_args" SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    rep_tc_args ])

    -- | What action to take in order to derive a class instance.
    -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as
    -- @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
    data DerivSpecMechanism
        -- | \"Standard\" classes
      = DerivSpecStock
        { DerivSpecMechanism -> DerivInstTys
    dsm_stock_dit    :: DerivInstTys
          -- ^ Information about the arguments to the class in the derived
          -- instance, including what type constructor the last argument is
          -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
        , DerivSpecMechanism
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
    dsm_stock_gen_fn ::
            SrcSpan -> TyCon  -- dit_rep_tc
                    -> [Type] -- dit_rep_tc_args
                    -> [Type] -- inst_tys
                    -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
          -- ^ This function returns four things:
          --
          -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
          --    (e.g., @compare (T x) (T y) = compare x y@)
          --
          -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.
          --    Most likely INLINE pragmas for class methods.
          --
          -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived
          --    instance. As examples, derived 'Generic' instances require
          --    associated type family instances, and derived 'Eq' and 'Ord'
          --    instances require top-level @con2tag@ functions.
          --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".
          --
          -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be
          --    suppressed. This is used to suppress unused warnings for record
          --    selectors when deriving 'Read', 'Show', or 'Generic'.
          --    See @Note [Deriving and unused record selectors]@.
        }

        -- | @GeneralizedNewtypeDeriving@
      | DerivSpecNewtype
        { DerivSpecMechanism -> DerivInstTys
    dsm_newtype_dit    :: DerivInstTys
          -- ^ Information about the arguments to the class in the derived
          -- instance, including what type constructor the last argument is
          -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
        , DerivSpecMechanism -> Type
    dsm_newtype_rep_ty :: Type
          -- ^ The newtype rep type.
        }

        -- | @DeriveAnyClass@
      | DerivSpecAnyClass

        -- | @DerivingVia@
      | DerivSpecVia
        { DerivSpecMechanism -> [Type]
    dsm_via_cls_tys :: [Type]
          -- ^ All arguments to the class besides the last one.
        , DerivSpecMechanism -> Type
    dsm_via_inst_ty :: Type
          -- ^ The last argument to the class.
        , DerivSpecMechanism -> Type
    dsm_via_ty      :: Type
          -- ^ The @via@ type
        }

    -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
    derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
    derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
    derivSpecMechanismToStrategy DerivSpecStock{}      = XStockStrategy GhcTc -> DerivStrategy GhcTc
    forall pass. XStockStrategy pass -> DerivStrategy pass
    StockStrategy NoExtField
    XStockStrategy GhcTc
    noExtField
    derivSpecMechanismToStrategy DerivSpecNewtype{}    = XNewtypeStrategy GhcTc -> DerivStrategy GhcTc
    forall pass. XNewtypeStrategy pass -> DerivStrategy pass
    NewtypeStrategy NoExtField
    XNewtypeStrategy GhcTc
    noExtField
    derivSpecMechanismToStrategy DerivSpecMechanism
    DerivSpecAnyClass     = XAnyClassStrategy GhcTc -> DerivStrategy GhcTc
    forall pass. XAnyClassStrategy pass -> DerivStrategy pass
    AnyclassStrategy NoExtField
    XAnyClassStrategy GhcTc
    noExtField
    derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
    dsm_via_ty = Type
    t}) = XViaStrategy GhcTc -> DerivStrategy GhcTc
    forall pass. XViaStrategy pass -> DerivStrategy pass
    ViaStrategy Type
    XViaStrategy GhcTc
    t

    isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
      :: DerivSpecMechanism -> Bool
    isDerivSpecStock :: DerivSpecMechanism -> Bool
    isDerivSpecStock (DerivSpecStock{}) = Bool
    True
    isDerivSpecStock DerivSpecMechanism
    _                  = Bool
    False

    isDerivSpecNewtype :: DerivSpecMechanism -> Bool
    isDerivSpecNewtype (DerivSpecNewtype{}) = Bool
    True
    isDerivSpecNewtype DerivSpecMechanism
    _                    = Bool
    False

    isDerivSpecAnyClass :: DerivSpecMechanism -> Bool
    isDerivSpecAnyClass DerivSpecMechanism
    DerivSpecAnyClass = Bool
    True
    isDerivSpecAnyClass DerivSpecMechanism
    _                 = Bool
    False

    isDerivSpecVia :: DerivSpecMechanism -> Bool
    isDerivSpecVia (DerivSpecVia{}) = Bool
    True
    isDerivSpecVia DerivSpecMechanism
    _                = Bool
    False

    instance Outputable DerivSpecMechanism where
      ppr :: DerivSpecMechanism -> SDoc
    ppr (DerivSpecStock{dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
    dsm_stock_dit = DerivInstTys
    dit})
        = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "DerivSpecStock")
             Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "dsm_stock_dit" SDoc -> SDoc -> SDoc
    <+> DerivInstTys -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DerivInstTys
    dit ])
      ppr (DerivSpecNewtype { dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
    dsm_newtype_dit = DerivInstTys
    dit, dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
    dsm_newtype_rep_ty = Type
    rep_ty })
        = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "DerivSpecNewtype")
             Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "dsm_newtype_dit"    SDoc -> SDoc -> SDoc
    <+> DerivInstTys -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DerivInstTys
    dit
                     , String -> SDoc
    text String
    "dsm_newtype_rep_ty" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    rep_ty ])
      ppr DerivSpecMechanism
    DerivSpecAnyClass = String -> SDoc
    text String
    "DerivSpecAnyClass"
      ppr (DerivSpecVia { dsm_via_cls_tys :: DerivSpecMechanism -> [Type]
    dsm_via_cls_tys = [Type]
    cls_tys, dsm_via_inst_ty :: DerivSpecMechanism -> Type
    dsm_via_inst_ty = Type
    inst_ty
                        , dsm_via_ty :: DerivSpecMechanism -> Type
    dsm_via_ty = Type
    via_ty })
        = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "DerivSpecVia")
             Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "dsm_via_cls_tys" SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    cls_tys
                     , String -> SDoc
    text String
    "dsm_via_inst_ty" SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    inst_ty
                     , String -> SDoc
    text String
    "dsm_via_ty"      SDoc -> SDoc -> SDoc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    via_ty ])

    {-
    Note [DerivEnv and DerivSpecMechanism]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    DerivEnv contains all of the bits and pieces that are common to every
    deriving strategy. (See Note [Deriving strategies] in GHC.Tc.Deriv.) Some deriving
    strategies impose stricter requirements on the types involved in the derived
    instance than others, and these differences are factored out into the
    DerivSpecMechanism type. Suppose that the derived instance looks like this:

      instance ... => C arg_1 ... arg_n

    Each deriving strategy imposes restrictions on arg_1 through arg_n as follows:

    * stock (DerivSpecStock):

      Stock deriving requires that:

      - n must be a positive number. This is checked by
        GHC.Tc.Deriv.expectNonNullaryClsArgs
      - arg_n must be an application of an algebraic type constructor. Here,
        "algebraic type constructor" means:

        + An ordinary data type constructor, or
        + A data family type constructor such that the arguments it is applied to
          give rise to a data family instance.

        This is checked by GHC.Tc.Deriv.expectAlgTyConApp.

      This extra structure is witnessed by the DerivInstTys data type, which stores
      arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor
      (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type
      constructor, then dit_rep_tc/dit_rep_tc_args are the same as
      dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then
      dit_rep_tc is the representation type constructor for the data family
      instance, and dit_rep_tc_args are the arguments to the representation type
      constructor in the corresponding instance.

    * newtype (DerivSpecNewtype):

      Newtype deriving imposes the same DerivInstTys requirements as stock
      deriving. This is necessary because we need to know what the underlying type
      that the newtype wraps is, and this information can only be learned by
      knowing dit_rep_tc.

    * anyclass (DerivSpecAnyclass):

      DeriveAnyClass is the most permissive deriving strategy of all, as it
      essentially imposes no requirements on the derived instance. This is because
      DeriveAnyClass simply derives an empty instance, so it does not need any
      particular knowledge about the types involved. It can do several things
      that stock/newtype deriving cannot do (#13154):

      - n can be 0. That is, one is allowed to anyclass-derive an instance with
        no arguments to the class, such as in this example:

          class C
          deriving anyclass instance C

      - One can derive an instance for a type that is not headed by a type
        constructor, such as in the following example:

          class C (n :: Nat)
          deriving instance C 0
          deriving instance C 1
          ...

      - One can derive an instance for a data family with no data family instances,
        such as in the following example:

          data family Foo a
          class C a
          deriving anyclass instance C (Foo a)

    * via (DerivSpecVia):

      Like newtype deriving, DerivingVia requires that n must be a positive number.
      This is because when one derives something like this:

        deriving via Foo instance C Bar

      Then the generated code must specifically mention Bar. However, in
      contrast with newtype deriving, DerivingVia does *not* require Bar to be
      an application of an algebraic type constructor. This is because the
      generated code simply defers to invoking `coerce`, which does not need to
      know anything in particular about Bar (besides that it is representationally
      equal to Foo). This allows DerivingVia to do some things that are not
      possible with newtype deriving, such as deriving instances for data families
      without data instances (#13154):

        data family Foo a
        newtype ByBar a = ByBar a
        class Baz a where ...
        instance Baz (ByBar a) where ...
        deriving via ByBar (Foo a) instance Baz (Foo a)
    -}

    -- | Whether GHC is processing a @deriving@ clause or a standalone deriving
    -- declaration.
    data DerivContext
      = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
                                     --
                                     -- * A @deriving@ clause (in which case
                                     --   @mb_wildcard@ is 'Nothing').
                                     --
                                     -- * A standalone deriving declaration with
                                     --   an extra-constraints wildcard as the
                                     --   context (in which case @mb_wildcard@ is
                                     --   @'Just' loc@, where @loc@ is the location
                                     --   of the wildcard.
                                     --
                                     -- GHC should infer the context.

      | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
                                     -- deriving declaration, where @theta@ is the
                                     -- context supplied by the user.

    instance Outputable DerivContext where
      ppr :: DerivContext -> SDoc
    ppr (InferContext Maybe SrcSpan
    standalone) = String -> SDoc
    text String
    "InferContext"  SDoc -> SDoc -> SDoc
    <+> Maybe SrcSpan -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe SrcSpan
    standalone
      ppr (SupplyContext [Type]
    theta)     = String -> SDoc
    text String
    "SupplyContext" SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    theta

    -- | Records whether a particular class can be derived by way of an
    -- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).
    --
    -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
    data OriginativeDerivStatus
      = CanDeriveStock            -- Stock class, can derive
          (SrcSpan -> TyCon -> [Type] -> [Type]
                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
      | StockClassError SDoc      -- Stock class, but can't do it
      | CanDeriveAnyClass         -- See Note [Deriving any class]
      | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass

    -- A stock class is one either defined in the Haskell report or for which GHC
    -- otherwise knows how to generate code for (possibly requiring the use of a
    -- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)

    -- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
    -- and whether or the constraint deals in types or kinds.
    data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind

    -- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to
    -- simplify when inferring a derived instance's context. These are used in all
    -- deriving strategies, but in the particular case of @DeriveAnyClass@, we
    -- need extra information. In particular, we need:
    --
    -- * 'to_anyclass_skols', the list of type variables bound by a class method's
    --   regular type signature, which should be rigid.
    --
    -- * 'to_anyclass_metas', the list of type variables bound by a class method's
    --   default type signature. These can be unified as necessary.
    --
    -- * 'to_anyclass_givens', the list of constraints from a class method's
    --   regular type signature, which can be used to help solve constraints
    --   in the 'to_wanted_origins'.
    --
    -- (Note that 'to_wanted_origins' will likely contain type variables from the
    -- derived type class or data type, neither of which will appear in
    -- 'to_anyclass_skols' or 'to_anyclass_metas'.)
    --
    -- For all other deriving strategies, it is always the case that
    -- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are
    -- empty.
    --
    -- Here is an example to illustrate this:
    --
    -- @
    -- class Foo a where
    --   bar :: forall b. Ix b => a -> b -> String
    --   default bar :: forall y. (Show a, Ix y) => a -> y -> String
    --   bar x y = show x ++ show (range (y, y))
    --
    --   baz :: Eq a => a -> a -> Bool
    --   default baz :: Ord a => a -> a -> Bool
    --   baz x y = compare x y == EQ
    --
    -- data Quux q = Quux deriving anyclass Foo
    -- @
    --
    -- Then it would generate two 'ThetaOrigin's, one for each method:
    --
    -- @
    -- [ ThetaOrigin { to_anyclass_skols  = [b]
    --               , to_anyclass_metas  = [y]
    --               , to_anyclass_givens = [Ix b]
    --               , to_wanted_origins  = [ Show (Quux q), Ix y
    --                                      , (Quux q -> b -> String) ~
    --                                        (Quux q -> y -> String)
    --                                      ] }
    -- , ThetaOrigin { to_anyclass_skols  = []
    --               , to_anyclass_metas  = []
    --               , to_anyclass_givens = [Eq (Quux q)]
    --               , to_wanted_origins  = [ Ord (Quux q)
    --                                      , (Quux q -> Quux q -> Bool) ~
    --                                        (Quux q -> Quux q -> Bool)
    --                                      ] }
    -- ]
    -- @
    --
    -- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
    -- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)
    --
    -- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
    -- in "GHC.Tc.Deriv.Infer" for an explanation of how 'to_wanted_origins' are
    -- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',
    -- 'to_anyclass_metas', and 'to_anyclass_givens' are used.
    data ThetaOrigin
      = ThetaOrigin { ThetaOrigin -> [TyVar]
    to_anyclass_skols  :: [TyVar]
                    , ThetaOrigin -> [TyVar]
    to_anyclass_metas  :: [TyVar]
                    , ThetaOrigin -> [Type]
    to_anyclass_givens :: ThetaType
                    , ThetaOrigin -> [PredOrigin]
    to_wanted_origins  :: [PredOrigin] }

    instance Outputable PredOrigin where
      ppr :: PredOrigin -> SDoc
    ppr (PredOrigin Type
    ty CtOrigin
    _ TypeOrKind
    _) = Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty -- The origin is not so interesting when debugging

    instance Outputable ThetaOrigin where
      ppr :: ThetaOrigin -> SDoc
    ppr (ThetaOrigin { to_anyclass_skols :: ThetaOrigin -> [TyVar]
    to_anyclass_skols  = [TyVar]
    ac_skols
                       , to_anyclass_metas :: ThetaOrigin -> [TyVar]
    to_anyclass_metas  = [TyVar]
    ac_metas
                       , to_anyclass_givens :: ThetaOrigin -> [Type]
    to_anyclass_givens = [Type]
    ac_givens
                       , to_wanted_origins :: ThetaOrigin -> [PredOrigin]
    to_wanted_origins  = [PredOrigin]
    wanted_origins })
        = SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "ThetaOrigin")
             Int
    2 ([SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "to_anyclass_skols  =" SDoc -> SDoc -> SDoc
    <+> [TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    ac_skols
                     , String -> SDoc
    text String
    "to_anyclass_metas  =" SDoc -> SDoc -> SDoc
    <+> [TyVar] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyVar]
    ac_metas
                     , String -> SDoc
    text String
    "to_anyclass_givens =" SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Type]
    ac_givens
                     , String -> SDoc
    text String
    "to_wanted_origins  =" SDoc -> SDoc -> SDoc
    <+> [PredOrigin] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [PredOrigin]
    wanted_origins ])

    mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
    mkPredOrigin :: CtOrigin -> TypeOrKind -> Type -> PredOrigin
    mkPredOrigin CtOrigin
    origin TypeOrKind
    t_or_k Type
    pred = Type -> CtOrigin -> TypeOrKind -> PredOrigin
    PredOrigin Type
    pred CtOrigin
    origin TypeOrKind
    t_or_k

    mkThetaOrigin :: CtOrigin -> TypeOrKind
                  -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType
                  -> ThetaOrigin
    mkThetaOrigin :: CtOrigin
    -> TypeOrKind
    -> [TyVar]
    -> [TyVar]
    -> [Type]
    -> [Type]
    -> ThetaOrigin
    mkThetaOrigin CtOrigin
    origin TypeOrKind
    t_or_k [TyVar]
    skols [TyVar]
    metas [Type]
    givens
      = [TyVar] -> [TyVar] -> [Type] -> [PredOrigin] -> ThetaOrigin
    ThetaOrigin [TyVar]
    skols [TyVar]
    metas [Type]
    givens ([PredOrigin] -> ThetaOrigin)
    -> ([Type] -> [PredOrigin]) -> [Type] -> ThetaOrigin
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Type -> PredOrigin) -> [Type] -> [PredOrigin]
    forall a b. (a -> b) -> [a] -> [b]
    map (CtOrigin -> TypeOrKind -> Type -> PredOrigin
    mkPredOrigin CtOrigin
    origin TypeOrKind
    t_or_k)

    -- A common case where the ThetaOrigin only contains wanted constraints, with
    -- no givens or locally scoped type variables.
    mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
    mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
    mkThetaOriginFromPreds = [TyVar] -> [TyVar] -> [Type] -> [PredOrigin] -> ThetaOrigin
    ThetaOrigin [] [] []

    substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
    substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
    substPredOrigin TCvSubst
    subst (PredOrigin Type
    pred CtOrigin
    origin TypeOrKind
    t_or_k)
      = Type -> CtOrigin -> TypeOrKind -> PredOrigin
    PredOrigin (HasCallStack => TCvSubst -> Type -> Type
    TCvSubst -> Type -> Type
    substTy TCvSubst
    subst Type
    pred) CtOrigin
    origin TypeOrKind
    t_or_k

    {-
    ************************************************************************
    *                                                                      *
                    Class deriving diagnostics
    *                                                                      *
    ************************************************************************

    Only certain blessed classes can be used in a deriving clause (without the
    assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
    are listed below in the definition of hasStockDeriving. The stockSideConditions
    function determines the criteria that needs to be met in order for a particular
    stock class to be able to be derived successfully.

    A class might be able to be used in a deriving clause if -XDeriveAnyClass
    is willing to support it. The canDeriveAnyClass function checks if this is the
    case.
    -}

    hasStockDeriving
      :: Class -> Maybe (SrcSpan
                         -> TyCon
                         -> [Type]
                         -> [Type]
                         -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
    hasStockDeriving :: Class
    -> Maybe
         (SrcSpan
          -> TyCon
          -> [Type]
          -> [Type]
          -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
    hasStockDeriving Class
    clas
      = Assoc
      Unique
      (SrcSpan
       -> TyCon
       -> [Type]
       -> [Type]
       -> TcM
            (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
             [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
    -> Unique
    -> Maybe
         (SrcSpan
          -> TyCon
          -> [Type]
          -> [Type]
          -> TcM
               (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
                [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
    forall a b. Eq a => Assoc a b -> a -> Maybe b
    assocMaybe Assoc
      Unique
      (SrcSpan
       -> TyCon
       -> [Type]
       -> [Type]
       -> TcM
            (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
             [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name]))
    [(Unique,
      SrcSpan
      -> TyCon
      -> [Type]
      -> [Type]
      -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]
    gen_list (Class -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique Class
    clas)
      where
        gen_list
          :: [(Unique, SrcSpan
                       -> TyCon
                       -> [Type]
                       -> [Type]
                       -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]
        gen_list :: [(Unique,
      SrcSpan
      -> TyCon
      -> [Type]
      -> [Type]
      -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]
    gen_list = [ (Unique
    eqClassKey,          (SrcSpan
     -> TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> m (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simpleM SrcSpan
    -> TyCon
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
    gen_Eq_binds)
                   , (Unique
    ordClassKey,         (SrcSpan
     -> TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> m (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simpleM SrcSpan
    -> TyCon
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
    gen_Ord_binds)
                   , (Unique
    enumClassKey,        (SrcSpan
     -> TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> m (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simpleM SrcSpan
    -> TyCon
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
    gen_Enum_binds)
                   , (Unique
    boundedClassKey,     (SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simple SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Bounded_binds)
                   , (Unique
    ixClassKey,          (SrcSpan
     -> TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> m (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simpleM SrcSpan
    -> TyCon
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
    gen_Ix_binds)
                   , (Unique
    showClassKey,        ((Name -> Fixity)
     -> SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {t} {t} {a} {c} {p} {a}.
    ((Name -> Fixity) -> t -> TyCon -> t -> (a, c))
    -> t
    -> TyCon
    -> t
    -> p
    -> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
    read_or_show (Name -> Fixity)
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    (Name -> Fixity)
    -> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Show_binds)
                   , (Unique
    readClassKey,        ((Name -> Fixity)
     -> SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {t} {t} {a} {c} {p} {a}.
    ((Name -> Fixity) -> t -> TyCon -> t -> (a, c))
    -> t
    -> TyCon
    -> t
    -> p
    -> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
    read_or_show (Name -> Fixity)
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    (Name -> Fixity)
    -> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Read_binds)
                   , (Unique
    dataClassKey,        (SrcSpan
     -> TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> m (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simpleM SrcSpan
    -> TyCon
    -> [Type]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
    gen_Data_binds)
                   , (Unique
    functorClassKey,     (SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simple SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Functor_binds)
                   , (Unique
    foldableClassKey,    (SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simple SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Foldable_binds)
                   , (Unique
    traversableClassKey, (SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simple SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Traversable_binds)
                   , (Unique
    liftClassKey,        (SrcSpan
     -> TyCon
     -> [Type]
     -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
         BagDerivStuff))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {t} {t} {a} {c} {p} {a} {a}.
    Monad m =>
    (t -> t -> t -> (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simple SrcSpan
    -> TyCon
    -> [Type]
    -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
        BagDerivStuff)
    SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
    gen_Lift_binds)
                   , (Unique
    genClassKey,         (TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           [GenLocated SrcSpanAnnA (Sig GhcPs)], FamInst))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {a} {b} {p} {p}.
    Monad m =>
    (TyCon -> t -> m (a, b, FamInst))
    -> p -> TyCon -> p -> t -> m (a, b, BagDerivStuff, [Name])
    generic (GenericKind
    -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
    gen_Generic_binds GenericKind
    Gen0))
                   , (Unique
    gen1ClassKey,        (TyCon
     -> [Type]
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
           [GenLocated SrcSpanAnnA (Sig GhcPs)], FamInst))
    -> SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM
         (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
          [GenLocated SrcSpanAnnA (Sig GhcPs)], BagDerivStuff, [Name])
    forall {m :: * -> *} {t} {a} {b} {p} {p}.
    Monad m =>
    (TyCon -> t -> m (a, b, FamInst))
    -> p -> TyCon -> p -> t -> m (a, b, BagDerivStuff, [Name])
    generic (GenericKind
    -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)
    gen_Generic_binds GenericKind
    Gen1)) ]

        simple :: (t -> t -> t -> (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simple t -> t -> t -> (a, c)
    gen_fn t
    loc t
    tc t
    tc_args p
    _
          = let (a
    binds, c
    deriv_stuff) = t -> t -> t -> (a, c)
    gen_fn t
    loc t
    tc t
    tc_args
            in (a, [a], c, [a]) -> m (a, [a], c, [a])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    binds, [], c
    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 :: (t -> t -> t -> m (a, c)) -> t -> t -> t -> p -> m (a, [a], c, [a])
    simpleM t -> t -> t -> m (a, c)
    gen_fn t
    loc t
    tc t
    tc_args p
    _
          = do { (a
    binds, c
    deriv_stuff) <- t -> t -> t -> m (a, c)
    gen_fn t
    loc t
    tc t
    tc_args
               ; (a, [a], c, [a]) -> m (a, [a], c, [a])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    binds, [], c
    deriv_stuff, []) }

        read_or_show :: ((Name -> Fixity) -> t -> TyCon -> t -> (a, c))
    -> t
    -> TyCon
    -> t
    -> p
    -> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
    read_or_show (Name -> Fixity) -> t -> TyCon -> t -> (a, c)
    gen_fn t
    loc TyCon
    tc t
    tc_args p
    _
          = do { Name -> Fixity
    fix_env <- TyCon -> TcM (Name -> Fixity)
    getDataConFixityFun TyCon
    tc
               ; let (a
    binds, c
    deriv_stuff) = (Name -> Fixity) -> t -> TyCon -> t -> (a, c)
    gen_fn Name -> Fixity
    fix_env t
    loc TyCon
    tc t
    tc_args
                     field_names :: [Name]
    field_names          = TyCon -> [Name]
    all_field_names TyCon
    tc
               ; (a, [a], c, [Name])
    -> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    binds, [], c
    deriv_stuff, [Name]
    field_names) }

        generic :: (TyCon -> t -> m (a, b, FamInst))
    -> p -> TyCon -> p -> t -> m (a, b, BagDerivStuff, [Name])
    generic TyCon -> t -> m (a, b, FamInst)
    gen_fn p
    _ TyCon
    tc p
    _ t
    inst_tys
          = do { (a
    binds, b
    sigs, FamInst
    faminst) <- TyCon -> t -> m (a, b, FamInst)
    gen_fn TyCon
    tc t
    inst_tys
               ; let field_names :: [Name]
    field_names = TyCon -> [Name]
    all_field_names TyCon
    tc
               ; (a, b, BagDerivStuff, [Name]) -> m (a, b, BagDerivStuff, [Name])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    binds, b
    sigs, DerivStuff -> BagDerivStuff
    forall a. a -> Bag a
    unitBag (FamInst -> DerivStuff
    DerivFamInst FamInst
    faminst), [Name]
    field_names) }

        -- See Note [Deriving and unused record selectors]
        all_field_names :: TyCon -> [Name]
    all_field_names = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map FieldLabel -> Name
    flSelector ([FieldLabel] -> [Name])
    -> (TyCon -> [FieldLabel]) -> TyCon -> [Name]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (DataCon -> [FieldLabel]) -> [DataCon] -> [FieldLabel]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap DataCon -> [FieldLabel]
    dataConFieldLabels
                                         ([DataCon] -> [FieldLabel])
    -> (TyCon -> [DataCon]) -> TyCon -> [FieldLabel]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyCon -> [DataCon]
    tyConDataCons

    {-
    Note [Deriving and unused record selectors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider this (see #13919):

      module Main (main) where

      data Foo = MkFoo {bar :: String} deriving Show

      main :: IO ()
      main = print (Foo "hello")

    Strictly speaking, the record selector `bar` is unused in this module, since
    neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
    However, the behavior of `main` is affected by the presence of `bar`, since
    it will print different output depending on whether `MkFoo` is defined using
    record selectors or not. Therefore, we do not to issue a
    "Defined but not used: ‘bar’" warning for this module, since removing `bar`
    changes the program's behavior. This is the reason behind the [Name] part of
    the return type of `hasStockDeriving`—it tracks all of the record selector
    `Name`s for which -Wunused-binds should be suppressed.

    Currently, the only three stock derived classes that require this are Read,
    Show, and Generic, as their derived code all depend on the record selectors
    of the derived data type's constructors.

    See also Note [Newtype deriving and unused constructors] in GHC.Tc.Deriv for
    another example of a similar trick.
    -}

    getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
    -- If the TyCon is locally defined, we want the local fixity env;
    -- but if it is imported (which happens for standalone deriving)
    -- we need to get the fixity env from the interface file
    -- c.f. GHC.Rename.Env.lookupFixity, and #9830
    getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
    getDataConFixityFun TyCon
    tc
      = do { Module
    this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
           ; if Module -> Name -> Bool
    nameIsLocalOrFrom Module
    this_mod Name
    name
             then do { FixityEnv
    fix_env <- TcRn FixityEnv
    getFixityEnv
                     ; (Name -> Fixity) -> TcM (Name -> Fixity)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (FixityEnv -> Name -> Fixity
    lookupFixity FixityEnv
    fix_env) }
             else do { ModIface
    iface <- SDoc -> Name -> TcRn ModIface
    loadInterfaceForName SDoc
    doc Name
    name
                                -- Should already be loaded!
                     ; (Name -> Fixity) -> TcM (Name -> Fixity)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ModIface -> OccName -> Fixity
    mi_fix ModIface
    iface (OccName -> Fixity) -> (Name -> OccName) -> Name -> Fixity
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> OccName
    nameOccName) } }
      where
        name :: Name
    name = TyCon -> Name
    tyConName TyCon
    tc
        doc :: SDoc
    doc = String -> SDoc
    text String
    "Data con fixities for" SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name

    ------------------------------------------------------------------
    -- Check side conditions that dis-allow derivability for the originative
    -- deriving strategies (stock and anyclass).
    -- See Note [Deriving strategies] in GHC.Tc.Deriv for an explanation of what
    -- "originative" means.
    --
    -- This is *apart* from the coerce-based strategies, newtype and via.
    --
    -- Here we get the representation tycon in case of family instances as it has
    -- the data constructors - but we need to be careful to fall back to the
    -- family tycon (with indexes) in error messages.

    checkOriginativeSideConditions
      :: DynFlags -> DerivContext -> Class -> [TcType]
      -> TyCon -> TyCon
      -> OriginativeDerivStatus
    checkOriginativeSideConditions :: DynFlags
    -> DerivContext
    -> Class
    -> [Type]
    -> TyCon
    -> TyCon
    -> OriginativeDerivStatus
    checkOriginativeSideConditions DynFlags
    dflags DerivContext
    deriv_ctxt Class
    cls [Type]
    cls_tys TyCon
    tc TyCon
    rep_tc
        -- First, check if stock deriving is possible...
      | Just Condition
    cond <- DerivContext -> Class -> Maybe Condition
    stockSideConditions DerivContext
    deriv_ctxt Class
    cls
      = case (Condition
    cond DynFlags
    dflags TyCon
    tc TyCon
    rep_tc) of
            NotValid SDoc
    err -> SDoc -> OriginativeDerivStatus
    StockClassError SDoc
    err  -- Class-specific error
            Validity
    IsValid  | [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (TyCon -> [Type] -> [Type]
    filterOutInvisibleTypes (Class -> TyCon
    classTyCon Class
    cls) [Type]
    cls_tys)
                       -- All stock derivable classes are unary in the sense that
                       -- there should be not types in cls_tys (i.e., no type args
                       -- other than last). Note that cls_types can contain
                       -- invisible types as well (e.g., for Generic1, which is
                       -- poly-kinded), so make sure those are not counted.
                     , Just SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
    gen_fn <- Class
    -> Maybe
         (SrcSpan
          -> TyCon
          -> [Type]
          -> [Type]
          -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
    hasStockDeriving Class
    cls
                       -> (SrcSpan
     -> TyCon
     -> [Type]
     -> [Type]
     -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))
    -> OriginativeDerivStatus
    CanDeriveStock SrcSpan
    -> TyCon
    -> [Type]
    -> [Type]
    -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])
    gen_fn
                     | Bool
    otherwise -> SDoc -> OriginativeDerivStatus
    StockClassError (Class -> [Type] -> SDoc
    classArgsErr Class
    cls [Type]
    cls_tys)
                       -- e.g. deriving( Eq s )

        -- ...if not, try falling back on DeriveAnyClass.
      | NotValid SDoc
    err <- DynFlags -> Validity
    canDeriveAnyClass DynFlags
    dflags
      = SDoc -> OriginativeDerivStatus
    NonDerivableClass SDoc
    err  -- Neither anyclass nor stock work

      | Bool
    otherwise
      = OriginativeDerivStatus
    CanDeriveAnyClass   -- DeriveAnyClass should work

    classArgsErr :: Class -> [Type] -> SDoc
    classArgsErr :: Class -> [Type] -> SDoc
    classArgsErr Class
    cls [Type]
    cls_tys = SDoc -> SDoc
    quotes (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Class -> [Type] -> Type
    mkClassPred Class
    cls [Type]
    cls_tys)) SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "is not a class"

    -- Side conditions (whether the datatype must have at least one constructor,
    -- required language extensions, etc.) for using GHC's stock deriving
    -- mechanism on certain classes (as opposed to classes that require
    -- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
    -- class for which stock deriving isn't possible.
    stockSideConditions :: DerivContext -> Class -> Maybe Condition
    stockSideConditions :: DerivContext -> Class -> Maybe Condition
    stockSideConditions DerivContext
    deriv_ctxt Class
    cls
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    eqClassKey          = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_args Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    ordClassKey         = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_args Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    showClassKey        = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_args Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    readClassKey        = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_args Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    enumClassKey        = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Condition
    cond_isEnumeration)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    ixClassKey          = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_enumOrProduct Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    boundedClassKey     = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Condition
    cond_std Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_enumOrProduct Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    dataClassKey        = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveDataTypeable Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Class -> Condition
    cond_args Class
    cls)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    functorClassKey     = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveFunctor Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Bool -> Bool -> Condition
    cond_functorOK Bool
    True Bool
    False)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    foldableClassKey    = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveFoldable Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Bool -> Bool -> Condition
    cond_functorOK Bool
    False Bool
    True)
                                               -- Functor/Fold/Trav works ok
                                               -- for rank-n types
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    traversableClassKey = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveTraversable Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Bool -> Bool -> Condition
    cond_functorOK Bool
    False Bool
    False)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    genClassKey         = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveGeneric Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_RepresentableOk)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    gen1ClassKey        = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveGeneric Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_Representable1Ok)
      | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    liftClassKey        = Condition -> Maybe Condition
    forall a. a -> Maybe a
    Just (Extension -> Condition
    checkFlag Extension
    LangExt.DeriveLift Condition -> Condition -> Condition
    `andCond`
                                               Condition
    cond_vanilla Condition -> Condition -> Condition
    `andCond`
                                               Class -> Condition
    cond_args Class
    cls)
      | Bool
    otherwise                      = Maybe Condition
    forall a. Maybe a
    Nothing
      where
        cls_key :: Unique
    cls_key = Class -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique Class
    cls
        cond_std :: Condition
    cond_std     = DerivContext -> Bool -> Condition
    cond_stdOK DerivContext
    deriv_ctxt Bool
    False
          -- Vanilla data constructors, at least one, and monotype arguments
        cond_vanilla :: Condition
    cond_vanilla = DerivContext -> Bool -> Condition
    cond_stdOK DerivContext
    deriv_ctxt Bool
    True
          -- Vanilla data constructors but allow no data cons or polytype arguments

    canDeriveAnyClass :: DynFlags -> Validity
    -- IsValid: we can (try to) derive it via an empty instance declaration
    -- NotValid s:  we can't, reason s
    canDeriveAnyClass :: DynFlags -> Validity
    canDeriveAnyClass DynFlags
    dflags
      | Bool -> Bool
    not (Extension -> DynFlags -> Bool
    xopt Extension
    LangExt.DeriveAnyClass DynFlags
    dflags)
      = SDoc -> Validity
    NotValid (String -> SDoc
    text String
    "Try enabling DeriveAnyClass")
      | Bool
    otherwise
      = Validity
    IsValid   -- OK!

    type Condition
       = DynFlags

      -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the
                  -- family 'TyCon'.

      -> TyCon    -- ^ For data families, this is the representation 'TyCon'.
                  -- Otherwise, this is the same as the other 'TyCon' argument.

      -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
                  -- possible. Otherwise, it's @'NotValid' err@, where @err@
                  -- explains what went wrong.

    orCond :: Condition -> Condition -> Condition
    orCond :: Condition -> Condition -> Condition
    orCond Condition
    c1 Condition
    c2 DynFlags
    dflags TyCon
    tc TyCon
    rep_tc
      = case (Condition
    c1 DynFlags
    dflags TyCon
    tc TyCon
    rep_tc, Condition
    c2 DynFlags
    dflags TyCon
    tc TyCon
    rep_tc) of
         (Validity
    IsValid,    Validity
    _)          -> Validity
    IsValid    -- c1 succeeds
         (Validity
    _,          Validity
    IsValid)    -> Validity
    IsValid    -- c21 succeeds
         (NotValid SDoc
    x, NotValid SDoc
    y) -> SDoc -> Validity
    NotValid (SDoc
    x SDoc -> SDoc -> SDoc
    $$ String -> SDoc
    text String
    "  or" SDoc -> SDoc -> SDoc
    $$ SDoc
    y)
                                                -- Both fail

    andCond :: Condition -> Condition -> Condition
    andCond :: Condition -> Condition -> Condition
    andCond Condition
    c1 Condition
    c2 DynFlags
    dflags TyCon
    tc TyCon
    rep_tc
      = Condition
    c1 DynFlags
    dflags TyCon
    tc TyCon
    rep_tc Validity -> Validity -> Validity
    `andValid` Condition
    c2 DynFlags
    dflags TyCon
    tc TyCon
    rep_tc

    -- | Some common validity checks shared among stock derivable classes. One
    -- check that absolutely must hold is that if an instance @C (T a)@ is being
    -- derived, then @T@ must be a tycon for a data type or a newtype. The
    -- remaining checks are only performed if using a @deriving@ clause (i.e.,
    -- they're ignored if using @StandaloneDeriving@):
    --
    -- 1. The data type must have at least one constructor (this check is ignored
    --    if using @EmptyDataDeriving@).
    --
    -- 2. The data type cannot have any GADT constructors.
    --
    -- 3. The data type cannot have any constructors with existentially quantified
    --    type variables.
    --
    -- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
    --
    -- 5. The data type cannot have fields with higher-rank types.
    cond_stdOK
      :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
                      -- user-supplied context, 'InferContext' if not.
                      -- If it is the former, we relax some of the validity checks
                      -- we would otherwise perform (i.e., "just go for it").

      -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
                      -- types (with no data constructors) even in the absence of
                      -- the -XEmptyDataDeriving extension.

      -> Condition
    cond_stdOK :: DerivContext -> Bool -> Condition
    cond_stdOK DerivContext
    deriv_ctxt Bool
    permissive DynFlags
    dflags TyCon
    tc TyCon
    rep_tc
      = Validity
    valid_ADT Validity -> Validity -> Validity
    `andValid` Validity
    valid_misc
      where
        valid_ADT, valid_misc :: Validity
        valid_ADT :: Validity
    valid_ADT
          | TyCon -> Bool
    isAlgTyCon TyCon
    tc Bool -> Bool -> Bool
    || TyCon -> Bool
    isDataFamilyTyCon TyCon
    tc
          = Validity
    IsValid
          | Bool
    otherwise
            -- Complain about functions, primitive types, and other tycons that
            -- stock deriving can't handle.
          = SDoc -> Validity
    NotValid (SDoc -> Validity) -> SDoc -> Validity
    forall a b. (a -> b) -> a -> b
    $ String -> SDoc
    text String
    "The last argument of the instance must be a"
                   SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "data or newtype application"

        valid_misc :: Validity
    valid_misc
          = case DerivContext
    deriv_ctxt of
             SupplyContext [Type]
    _ -> Validity
    IsValid
                    -- Don't check these conservative conditions for
                    -- standalone deriving; just generate the code
                    -- and let the typechecker handle the result
             InferContext Maybe SrcSpan
    wildcard
               | [DataCon] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DataCon]
    data_cons -- 1.
               , Bool -> Bool
    not Bool
    permissive
               -> Extension -> Condition
    checkFlag Extension
    LangExt.EmptyDataDeriving DynFlags
    dflags TyCon
    tc TyCon
    rep_tc Validity -> Validity -> Validity
    `orValid`
                  SDoc -> Validity
    NotValid (TyCon -> SDoc
    no_cons_why TyCon
    rep_tc SDoc -> SDoc -> SDoc
    $$ SDoc
    empty_data_suggestion)
               | Bool -> Bool
    not ([SDoc] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [SDoc]
    con_whys)
               -> SDoc -> Validity
    NotValid ([SDoc] -> SDoc
    vcat [SDoc]
    con_whys SDoc -> SDoc -> SDoc
    $$ Maybe SrcSpan -> SDoc
    forall {a}. Maybe a -> SDoc
    possible_fix_suggestion Maybe SrcSpan
    wildcard)
               | Bool
    otherwise
               -> Validity
    IsValid

        empty_data_suggestion :: SDoc
    empty_data_suggestion =
          String -> SDoc
    text String
    "Use EmptyDataDeriving to enable deriving for empty data types"
        possible_fix_suggestion :: Maybe a -> SDoc
    possible_fix_suggestion Maybe a
    wildcard
          = case Maybe a
    wildcard of
              Just a
    _ ->
                String -> SDoc
    text String
    "Possible fix: fill in the wildcard constraint yourself"
              Maybe a
    Nothing ->
                String -> SDoc
    text String
    "Possible fix: use a standalone deriving declaration instead"
        data_cons :: [DataCon]
    data_cons  = TyCon -> [DataCon]
    tyConDataCons TyCon
    rep_tc
        con_whys :: [SDoc]
    con_whys   = [Validity] -> [SDoc]
    getInvalids ((DataCon -> Validity) -> [DataCon] -> [Validity]
    forall a b. (a -> b) -> [a] -> [b]
    map DataCon -> Validity
    check_con [DataCon]
    data_cons)

        check_con :: DataCon -> Validity
        check_con :: DataCon -> Validity
    check_con DataCon
    con
          | Bool -> Bool
    not ([EqSpec] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [EqSpec]
    eq_spec) -- 2.
          = String -> Validity
    bad String
    "is a GADT"
          | Bool -> Bool
    not ([TyVar] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVar]
    ex_tvs) -- 3.
          = String -> Validity
    bad String
    "has existential type variables in its type"
          | Bool -> Bool
    not ([Type] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Type]
    theta) -- 4.
          = String -> Validity
    bad String
    "has constraints in its type"
          | Bool -> Bool
    not (Bool
    permissive Bool -> Bool -> Bool
    || (Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    isTauTy ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> a -> b
    $ DataCon -> [Scaled Type]
    dataConOrigArgTys DataCon
    con)) -- 5.
          = String -> Validity
    bad String
    "has a higher-rank type"
          | Bool
    otherwise
          = Validity
    IsValid
          where
            ([TyVar]
    _, [TyVar]
    ex_tvs, [EqSpec]
    eq_spec, [Type]
    theta, [Scaled Type]
    _, Type
    _) = DataCon
    -> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
    dataConFullSig DataCon
    con
            bad :: String -> Validity
    bad String
    msg = SDoc -> Validity
    NotValid (DataCon -> SDoc -> SDoc
    badCon DataCon
    con (String -> SDoc
    text String
    msg))

    no_cons_why :: TyCon -> SDoc
    no_cons_why :: TyCon -> SDoc
    no_cons_why TyCon
    rep_tc = SDoc -> SDoc
    quotes (TyCon -> SDoc
    pprSourceTyCon TyCon
    rep_tc) SDoc -> SDoc -> SDoc
    <+>
                         String -> SDoc
    text String
    "must have at least one data constructor"

    cond_RepresentableOk :: Condition
    cond_RepresentableOk :: Condition
    cond_RepresentableOk DynFlags
    _ TyCon
    _ TyCon
    rep_tc = TyCon -> Validity
    canDoGenerics TyCon
    rep_tc

    cond_Representable1Ok :: Condition
    cond_Representable1Ok :: Condition
    cond_Representable1Ok DynFlags
    _ TyCon
    _ TyCon
    rep_tc = TyCon -> Validity
    canDoGenerics1 TyCon
    rep_tc

    cond_enumOrProduct :: Class -> Condition
    cond_enumOrProduct :: Class -> Condition
    cond_enumOrProduct Class
    cls = Condition
    cond_isEnumeration Condition -> Condition -> Condition
    `orCond`
                             (Condition
    cond_isProduct Condition -> Condition -> Condition
    `andCond` Class -> Condition
    cond_args Class
    cls)

    cond_args :: Class -> Condition
    -- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
    -- by generating specialised code.  For others (eg 'Data') we don't.
    -- For even others (eg 'Lift'), unlifted types aren't even a special
    -- consideration!
    cond_args :: Class -> Condition
    cond_args Class
    cls DynFlags
    _ TyCon
    _ TyCon
    rep_tc
      = case [Type]
    bad_args of
          []     -> Validity
    IsValid
          (Type
    ty:[Type]
    _) -> SDoc -> Validity
    NotValid (SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "Don't know how to derive" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    cls))
                                 Int
    2 (String -> SDoc
    text String
    "for type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)))
      where
        bad_args :: [Type]
    bad_args = [ Type
    arg_ty | DataCon
    con <- TyCon -> [DataCon]
    tyConDataCons TyCon
    rep_tc
                            , Scaled Type
    _ Type
    arg_ty <- DataCon -> [Scaled Type]
    dataConOrigArgTys DataCon
    con
                            , HasDebugCallStack => Type -> Maybe Bool
    Type -> Maybe Bool
    isLiftedType_maybe Type
    arg_ty Maybe Bool -> Maybe Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    True
                            , Bool -> Bool
    not (Type -> Bool
    ok_ty Type
    arg_ty) ]

        cls_key :: Unique
    cls_key = Class -> Unique
    classKey Class
    cls
        ok_ty :: Type -> Bool
    ok_ty Type
    arg_ty
         | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    eqClassKey   = Type
    -> [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -> Bool
    forall a. Type -> [(Type, a)] -> Bool
    check_in Type
    arg_ty [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
    ordOpTbl
         | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    ordClassKey  = Type
    -> [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] -> Bool
    forall a. Type -> [(Type, a)] -> Bool
    check_in Type
    arg_ty [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
    ordOpTbl
         | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    showClassKey = Type
    -> [(Type,
         GenLocated SrcSpanAnnA (HsExpr GhcPs)
         -> GenLocated SrcSpanAnnA (HsExpr GhcPs))]
    -> Bool
    forall a. Type -> [(Type, a)] -> Bool
    check_in Type
    arg_ty [(Type,
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
      -> GenLocated SrcSpanAnnA (HsExpr GhcPs))]
    [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
    boxConTbl
         | Unique
    cls_key Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    liftClassKey = Bool
    True     -- Lift is levity-polymorphic
         | Bool
    otherwise               = Bool
    False    -- Read, Ix etc

        check_in :: Type -> [(Type,a)] -> Bool
        check_in :: forall a. Type -> [(Type, a)] -> Bool
    check_in Type
    arg_ty [(Type, a)]
    tbl = ((Type, a) -> Bool) -> [(Type, a)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> Type -> Bool
    eqType Type
    arg_ty (Type -> Bool) -> ((Type, a) -> Type) -> (Type, a) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Type, a) -> Type
    forall a b. (a, b) -> a
    fst) [(Type, a)]
    tbl

    cond_isEnumeration :: Condition
    cond_isEnumeration :: Condition
    cond_isEnumeration DynFlags
    _ TyCon
    _ TyCon
    rep_tc
      | TyCon -> Bool
    isEnumerationTyCon TyCon
    rep_tc = Validity
    IsValid
      | Bool
    otherwise                 = SDoc -> Validity
    NotValid SDoc
    why
      where
        why :: SDoc
    why = [SDoc] -> SDoc
    sep [ SDoc -> SDoc
    quotes (TyCon -> SDoc
    pprSourceTyCon TyCon
    rep_tc) SDoc -> SDoc -> SDoc
    <+>
                      String -> SDoc
    text String
    "must be an enumeration type"
                  , String -> SDoc
    text String
    "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
                      -- See Note [Enumeration types] in GHC.Core.TyCon

    cond_isProduct :: Condition
    cond_isProduct :: Condition
    cond_isProduct DynFlags
    _ TyCon
    _ TyCon
    rep_tc
      | Just DataCon
    _ <- TyCon -> Maybe DataCon
    tyConSingleDataCon_maybe TyCon
    rep_tc = Validity
    IsValid
      | Bool
    otherwise                                 = SDoc -> Validity
    NotValid SDoc
    why
      where
        why :: SDoc
    why = SDoc -> SDoc
    quotes (TyCon -> SDoc
    pprSourceTyCon TyCon
    rep_tc) SDoc -> SDoc -> SDoc
    <+>
              String -> SDoc
    text String
    "must have precisely one constructor"

    cond_functorOK :: Bool -> Bool -> Condition
    -- OK for Functor/Foldable/Traversable class
    -- Currently: (a) at least one argument
    --            (b) don't use argument contravariantly
    --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
    --            (d) optionally: don't use function types
    --            (e) no "stupid context" on data type
    cond_functorOK :: Bool -> Bool -> Condition
    cond_functorOK Bool
    allowFunctions Bool
    allowExQuantifiedLastTyVar DynFlags
    _ TyCon
    _ TyCon
    rep_tc
      | [TyVar] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVar]
    tc_tvs
      = SDoc -> Validity
    NotValid (String -> SDoc
    text String
    "Data type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    rep_tc)
                  SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "must have some type parameters")

      | Bool -> Bool
    not ([Type] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Type]
    bad_stupid_theta)
      = SDoc -> Validity
    NotValid (String -> SDoc
    text String
    "Data type" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    rep_tc)
                  SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "must not have a class context:" SDoc -> SDoc -> SDoc
    <+> [Type] -> SDoc
    pprTheta [Type]
    bad_stupid_theta)

      | Bool
    otherwise
      = [Validity] -> Validity
    allValid ((DataCon -> Validity) -> [DataCon] -> [Validity]
    forall a b. (a -> b) -> [a] -> [b]
    map DataCon -> Validity
    check_con [DataCon]
    data_cons)
      where
        tc_tvs :: [TyVar]
    tc_tvs            = TyCon -> [TyVar]
    tyConTyVars TyCon
    rep_tc
        last_tv :: TyVar
    last_tv           = [TyVar] -> TyVar
    forall a. [a] -> a
    last [TyVar]
    tc_tvs
        bad_stupid_theta :: [Type]
    bad_stupid_theta  = (Type -> Bool) -> [Type] -> [Type]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Type -> Bool
    is_bad (TyCon -> [Type]
    tyConStupidTheta TyCon
    rep_tc)
        is_bad :: Type -> Bool
    is_bad Type
    pred       = TyVar
    last_tv TyVar -> VarSet -> Bool
    `elemVarSet` Type -> VarSet
    exactTyCoVarsOfType Type
    pred
          -- See Note [Check that the type variable is truly universal]

        data_cons :: [DataCon]
    data_cons = TyCon -> [DataCon]
    tyConDataCons TyCon
    rep_tc
        check_con :: DataCon -> Validity
    check_con DataCon
    con = [Validity] -> Validity
    allValid (DataCon -> Validity
    check_universal DataCon
    con Validity -> [Validity] -> [Validity]
    forall a. a -> [a] -> [a]
    : FFoldType Validity -> DataCon -> [Validity]
    forall a. FFoldType a -> DataCon -> [a]
    foldDataConArgs (DataCon -> FFoldType Validity
    ft_check DataCon
    con) DataCon
    con)

        check_universal :: DataCon -> Validity
        check_universal :: DataCon -> Validity
    check_universal DataCon
    con
          | Bool
    allowExQuantifiedLastTyVar
          = Validity
    IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
                    -- in GHC.Tc.Deriv.Functor
          | Just TyVar
    tv <- Type -> Maybe TyVar
    getTyVar_maybe ([Type] -> Type
    forall a. [a] -> a
    last (Type -> [Type]
    tyConAppArgs (DataCon -> Type
    dataConOrigResTy DataCon
    con)))
          , TyVar
    tv TyVar -> [TyVar] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` DataCon -> [TyVar]
    dataConUnivTyVars DataCon
    con
          , Bool -> Bool
    not (TyVar
    tv TyVar -> VarSet -> Bool
    `elemVarSet` [Type] -> VarSet
    exactTyCoVarsOfTypes (DataCon -> [Type]
    dataConTheta DataCon
    con))
          = Validity
    IsValid   -- See Note [Check that the type variable is truly universal]
          | Bool
    otherwise
          = SDoc -> Validity
    NotValid (DataCon -> SDoc -> SDoc
    badCon DataCon
    con SDoc
    existential)

        ft_check :: DataCon -> FFoldType Validity
        ft_check :: DataCon -> FFoldType Validity
    ft_check DataCon
    con = FT { ft_triv :: Validity
    ft_triv = Validity
    IsValid, ft_var :: Validity
    ft_var = Validity
    IsValid
                          , ft_co_var :: Validity
    ft_co_var = SDoc -> Validity
    NotValid (DataCon -> SDoc -> SDoc
    badCon DataCon
    con SDoc
    covariant)
                          , ft_fun :: Validity -> Validity -> Validity
    ft_fun = \Validity
    x Validity
    y -> if Bool
    allowFunctions then Validity
    x Validity -> Validity -> Validity
    `andValid` Validity
    y
                                                               else SDoc -> Validity
    NotValid (DataCon -> SDoc -> SDoc
    badCon DataCon
    con SDoc
    functions)
                          , ft_tup :: TyCon -> [Validity] -> Validity
    ft_tup = \TyCon
    _ [Validity]
    xs  -> [Validity] -> Validity
    allValid [Validity]
    xs
                          , ft_ty_app :: Type -> Type -> Validity -> Validity
    ft_ty_app = \Type
    _ Type
    _ Validity
    x -> Validity
    x
                          , ft_bad_app :: Validity
    ft_bad_app = SDoc -> Validity
    NotValid (DataCon -> SDoc -> SDoc
    badCon DataCon
    con SDoc
    wrong_arg)
                          , ft_forall :: TyVar -> Validity -> Validity
    ft_forall = \TyVar
    _ Validity
    x   -> Validity
    x }

        existential :: SDoc
    existential = String -> SDoc
    text String
    "must be truly polymorphic in the last argument of the data type"
        covariant :: SDoc
    covariant   = String -> SDoc
    text String
    "must not use the type variable in a function argument"
        functions :: SDoc
    functions   = String -> SDoc
    text String
    "must not contain function types"
        wrong_arg :: SDoc
    wrong_arg   = String -> SDoc
    text String
    "must use the type variable only as the last argument of a data type"

    checkFlag :: LangExt.Extension -> Condition
    checkFlag :: Extension -> Condition
    checkFlag Extension
    flag DynFlags
    dflags TyCon
    _ TyCon
    _
      | Extension -> DynFlags -> Bool
    xopt Extension
    flag DynFlags
    dflags = Validity
    IsValid
      | Bool
    otherwise        = SDoc -> Validity
    NotValid SDoc
    why
      where
        why :: SDoc
    why = String -> SDoc
    text String
    "You need " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    flag_str
              SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "to derive an instance for this class"
        flag_str :: String
    flag_str = case [ FlagSpec Extension -> String
    forall flag. FlagSpec flag -> String
    flagSpecName FlagSpec Extension
    f | FlagSpec Extension
    f <- [FlagSpec Extension]
    xFlags , FlagSpec Extension -> Extension
    forall flag. FlagSpec flag -> flag
    flagSpecFlag FlagSpec Extension
    f Extension -> Extension -> Bool
    forall a. Eq a => a -> a -> Bool
    == Extension
    flag ] of
                     [String
    s]   -> String
    s
                     [String]
    other -> String -> SDoc -> String
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "checkFlag" ([String] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [String]
    other)

    std_class_via_coercible :: Class -> Bool
    -- These standard classes can be derived for a newtype
    -- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
    -- because giving so gives the same results as generating the boilerplate
    std_class_via_coercible :: Class -> Bool
    std_class_via_coercible Class
    clas
      = Class -> Unique
    classKey Class
    clas Unique -> [Unique] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Unique
    eqClassKey, Unique
    ordClassKey, Unique
    ixClassKey, Unique
    boundedClassKey]
            -- Not Read/Show because they respect the type
            -- Not Enum, because newtypes are never in Enum

    non_coercible_class :: Class -> Bool
    -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
    -- by Coercible, even with -XGeneralizedNewtypeDeriving
    -- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
    -- instance behave differently if there's a non-lawful Applicative out there.
    -- Besides, with roles, Coercible-deriving Traversable is ill-roled.
    non_coercible_class :: Class -> Bool
    non_coercible_class Class
    cls
      = Class -> Unique
    classKey Class
    cls Unique -> [Unique] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` ([ Unique
    readClassKey, Unique
    showClassKey, Unique
    dataClassKey
                             , Unique
    genClassKey, Unique
    gen1ClassKey, Unique
    typeableClassKey
                             , Unique
    traversableClassKey, Unique
    liftClassKey ])

    badCon :: DataCon -> SDoc -> SDoc
    badCon :: DataCon -> SDoc -> SDoc
    badCon DataCon
    con SDoc
    msg = String -> SDoc
    text String
    "Constructor" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    con) SDoc -> SDoc -> SDoc
    <+> SDoc
    msg

    ------------------------------------------------------------------

    newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
    newDerivClsInst :: forall theta. [Type] -> DerivSpec theta -> TcM ClsInst
    newDerivClsInst [Type]
    theta (DS { ds_name :: forall theta. DerivSpec theta -> Name
    ds_name = Name
    dfun_name, ds_overlap :: forall theta. DerivSpec theta -> Maybe OverlapMode
    ds_overlap = Maybe OverlapMode
    overlap_mode
                              , ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
    ds_tvs = [TyVar]
    tvs, ds_cls :: forall theta. DerivSpec theta -> Class
    ds_cls = Class
    clas, ds_tys :: forall theta. DerivSpec theta -> [Type]
    ds_tys = [Type]
    tys })
      = Maybe OverlapMode
    -> Name -> [TyVar] -> [Type] -> Class -> [Type] -> TcM ClsInst
    newClsInst Maybe OverlapMode
    overlap_mode Name
    dfun_name [TyVar]
    tvs [Type]
    theta Class
    clas [Type]
    tys

    extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
    -- Add new locally-defined instances; don't bother to check
    -- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance
    extendLocalInstEnv :: forall a. [ClsInst] -> TcM a -> TcM a
    extendLocalInstEnv [ClsInst]
    dfuns TcM a
    thing_inside
     = do { TcGblEnv
    env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
    forall gbl lcl. TcRnIf gbl lcl gbl
    getGblEnv
          ; let  inst_env' :: InstEnv
    inst_env' = InstEnv -> [ClsInst] -> InstEnv
    extendInstEnvList (TcGblEnv -> InstEnv
    tcg_inst_env TcGblEnv
    env) [ClsInst]
    dfuns
                 env' :: TcGblEnv
    env'      = TcGblEnv
    env { tcg_inst_env :: InstEnv
    tcg_inst_env = InstEnv
    inst_env' }
          ; TcGblEnv -> TcM a -> TcM a
    forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    setGblEnv TcGblEnv
    env' TcM a
    thing_inside }

    {-
    Note [Deriving any class]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Classic uses of a deriving clause, or a standalone-deriving declaration, are
    for:
      * a stock class like Eq or Show, for which GHC knows how to generate
        the instance code
      * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving

    The DeriveAnyClass extension adds a third way to derive instances, based on
    empty instance declarations.

    The canonical use case is in combination with GHC.Generics and default method
    signatures. These allow us to have instance declarations being empty, but still
    useful, e.g.

      data T a = ...blah..blah... deriving( Generic )
      instance C a => C (T a)  -- No 'where' clause

    where C is some "random" user-defined class.

    This boilerplate code can be replaced by the more compact

      data T a = ...blah..blah... deriving( Generic, C )

    if DeriveAnyClass is enabled.

    This is not restricted to Generics; any class can be derived, simply giving
    rise to an empty instance.

    See Note [Gathering and simplifying constraints for DeriveAnyClass] in
    GHC.Tc.Deriv.Infer for an explanation hof how the instance context is inferred for
    DeriveAnyClass.

    Note [Check that the type variable is truly universal]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For Functor and Traversable instances, we must check that the *last argument*
    of the type constructor is used truly universally quantified.  Example

       data T a b where
         T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
         T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
         T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
         T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
         T5 :: b -> T b b           -- No!  'b' is constrained
         T6 :: T a (b,b)            -- No!  'b' is constrained

    Notice that only the first of these constructors is vanilla H-98. We only
    need to take care about the last argument (b in this case).  See #8678.
    Eg. for T1-T3 we can write

         fmap f (T1 a b) = T1 a (f b)
         fmap f (T2 b c) = T2 (f b) c
         fmap f (T3 x)   = T3 (f x)

    We need not perform these checks for Foldable instances, however, since
    functions in Foldable can only consume existentially quantified type variables,
    rather than produce them (as is the case in Functor and Traversable functions.)
    As a result, T can have a derived Foldable instance:

        foldr f z (T1 a b) = f b z
        foldr f z (T2 b c) = f b z
        foldr f z (T3 x)   = f x z
        foldr f z (T4 x)   = f x z
        foldr f z (T5 x)   = f x z
        foldr _ z T6       = z

    See Note [DeriveFoldable with ExistentialQuantification] in GHC.Tc.Deriv.Functor.

    For Functor and Traversable, we must take care not to let type synonyms
    unfairly reject a type for not being truly universally quantified. An
    example of this is:

        type C (a :: Constraint) b = a
        data T a b = C (Show a) b => MkT b

    Here, the existential context (C (Show a) b) does technically mention the last
    type variable b. But this is OK, because expanding the type synonym C would give
    us the context (Show a), which doesn't mention b. Therefore, we must make sure
    to expand type synonyms before performing this check. Not doing so led to #13813.
    -}