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

-}

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}

-- | Error-checking and other utilities for @deriving@ clauses or declarations.
module GHC.Tc.Deriv.Utils (
        DerivM, DerivEnv(..),
        DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec,
        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
        isDerivSpecNewtype, isDerivSpecAnyClass,
        isDerivSpecVia, zonkDerivSpecMechanism,
        DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),
        isStandaloneDeriv, isStandaloneWildcardDeriv,
        askDerivUserTypeCtxt, mkDerivOrigin,
        PredSpec(..), ThetaSpec,
        mkDirectThetaSpec, substPredSpec, captureThetaSpecConstraints,
        checkOriginativeSideConditions, hasStockDeriving,
        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.Core.FamInstEnv
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.Errors.Types
import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical)
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Unify (tcSubTypeSigma)
import GHC.Tc.Utils.Zonk
import GHC.Builtin.Names.TH (liftClassKey)
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Utils.Misc
import GHC.Types.Var.Set

import Control.Monad.Trans.Reader
import Data.Foldable (traverse_)
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

-- | Return 'InstDeclCtxt' if processing with a standalone @deriving@
-- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause.
askDerivUserTypeCtxt :: DerivM UserTypeCtxt
askDerivUserTypeCtxt :: DerivM UserTypeCtxt
askDerivUserTypeCtxt = (DerivEnv -> UserTypeCtxt) -> DerivM UserTypeCtxt
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (DerivContext -> UserTypeCtxt
go (DerivContext -> UserTypeCtxt)
-> (DerivEnv -> DerivContext) -> DerivEnv -> UserTypeCtxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivEnv -> DerivContext
denv_ctxt)
  where
    go :: DerivContext -> UserTypeCtxt
    go :: DerivContext -> UserTypeCtxt
go (SupplyContext {})     = Bool -> UserTypeCtxt
InstDeclCtxt Bool
True
    go (InferContext Just{})  = Bool -> UserTypeCtxt
InstDeclCtxt Bool
True
    go (InferContext Maybe SrcSpan
Nothing) = UserTypeCtxt
DerivClauseCtxt

-- | @'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. If the
    --   @denv_ctxt@ is 'InferContext', these will be 'TcTyVar' skolems.
    --   If the @denv_ctxt@ is 'SupplyContext', these will be ordinary 'TyVar's.
    --   See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
    --
    --   All type variables that appear in the 'denv_inst_tys', 'denv_ctxt',
    --   'denv_skol_info', and 'denv_strat' should come from 'denv_tvs'.
  , 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 -> SkolemInfo
denv_skol_info    :: SkolemInfo
    -- ^ The 'SkolemInfo' used to skolemise the @denv_tvs@ in the case where
    --   the 'denv_ctxt' is 'InferContext'.
  , 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_skol_info :: DerivEnv -> SkolemInfo
denv_skol_info    = SkolemInfo
skol_info
                , 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_skol_info"    SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
                 , 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 -> SkolemInfo
ds_skol_info           :: SkolemInfo
                          , forall theta. DerivSpec theta -> UserTypeCtxt
ds_user_ctxt           :: UserTypeCtxt
                          , 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 rest of the DerivSpec.
        -- If we are inferring an instance context, the tyvars will be TcTyVar
        -- skolems. After the instance context inference is over, the tyvars
        -- will be zonked to TyVars. See
        -- Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.

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

        -- The ds_skol_info is the SkolemInfo that was used to skolemise the
        -- TcTyVars (if we are inferring an instance context). The ds_user_ctxt
        -- is the UserTypeCtxt that allows error messages to know if we are in
        -- a deriving clause or a standalone deriving declaration.

        -- 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_skol_info :: forall theta. DerivSpec theta -> SkolemInfo
ds_skol_info = SkolemInfo
skol_info,
                   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_skol_info            =" SDoc -> SDoc -> SDoc
<+> SkolemInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfo
skol_info
               , 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

-- | Set the 'ds_theta' in a 'DerivSpec'.
setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta :: forall theta' theta. theta' -> DerivSpec theta -> DerivSpec theta'
setDerivSpecTheta theta'
theta DerivSpec theta
ds = DerivSpec theta
ds{ds_theta :: theta'
ds_theta = theta'
theta}

-- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's.
-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".
--
-- This is only used in the final zonking step when inferring
-- the context for a derived instance.
-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
zonkDerivSpec :: DerivSpec ThetaType -> TcM (DerivSpec ThetaType)
zonkDerivSpec :: DerivSpec [Type] -> TcM (DerivSpec [Type])
zonkDerivSpec ds :: DerivSpec [Type]
ds@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = [Type]
theta
                     , ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
tys, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
                     }) = do
  (ZonkEnv
ze, [TyVar]
tvs') <- [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs [TyVar]
tvs
  [Type]
theta'     <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
theta
  [Type]
tys'       <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
tys
  DerivSpecMechanism
mechanism' <- ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism
zonkDerivSpecMechanism ZonkEnv
ze DerivSpecMechanism
mechanism
  DerivSpec [Type] -> TcM (DerivSpec [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivSpec [Type]
ds{ ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs', ds_theta :: [Type]
ds_theta = [Type]
theta'
         , ds_tys :: [Type]
ds_tys = [Type]
tys', ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism'
         }

-- | 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 -> StockGenFns
dsm_stock_gen_fns :: StockGenFns
      -- ^ How to generate the instance bindings and associated type family
      -- instances.
    }

    -- | @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 XStockStrategy GhcTc
NoExtField
noExtField
derivSpecMechanismToStrategy DerivSpecNewtype{}    = XNewtypeStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy XNewtypeStrategy GhcTc
NoExtField
noExtField
derivSpecMechanismToStrategy DerivSpecMechanism
DerivSpecAnyClass     = XAnyClassStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy XAnyClassStrategy GhcTc
NoExtField
noExtField
derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
t}) = XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcTc
Type
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

-- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's.
-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".
--
-- This is only used in the final zonking step when inferring
-- the context for a derived instance.
-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism
zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism
zonkDerivSpecMechanism ZonkEnv
ze DerivSpecMechanism
mechanism =
  case DerivSpecMechanism
mechanism of
    DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit     = DerivInstTys
dit
                   , dsm_stock_gen_fns :: DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns
                   } -> do
      DerivInstTys
dit' <- ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys ZonkEnv
ze DerivInstTys
dit
      DerivSpecMechanism -> TcM DerivSpecMechanism
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivSpecMechanism -> TcM DerivSpecMechanism)
-> DerivSpecMechanism -> TcM DerivSpecMechanism
forall a b. (a -> b) -> a -> b
$ DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit     = DerivInstTys
dit'
                            , dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns
                            }
    DerivSpecNewtype { dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit    = DerivInstTys
dit
                     , dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rep_ty
                     } -> do
      DerivInstTys
dit'    <- ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys ZonkEnv
ze DerivInstTys
dit
      Type
rep_ty' <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
rep_ty
      DerivSpecMechanism -> TcM DerivSpecMechanism
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivSpecMechanism -> TcM DerivSpecMechanism)
-> DerivSpecMechanism -> TcM DerivSpecMechanism
forall a b. (a -> b) -> a -> b
$ DerivSpecNewtype { dsm_newtype_dit :: DerivInstTys
dsm_newtype_dit    = DerivInstTys
dit'
                              , dsm_newtype_rep_ty :: Type
dsm_newtype_rep_ty = Type
rep_ty'
                              }
    DerivSpecMechanism
DerivSpecAnyClass ->
      DerivSpecMechanism -> TcM DerivSpecMechanism
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivSpecMechanism
DerivSpecAnyClass
    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
                 } -> do
      [Type]
cls_tys' <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
cls_tys
      Type
inst_ty' <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
inst_ty
      Type
via_ty'  <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
via_ty
      DerivSpecMechanism -> TcM DerivSpecMechanism
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivSpecMechanism -> TcM DerivSpecMechanism)
-> DerivSpecMechanism -> TcM DerivSpecMechanism
forall a b. (a -> b) -> a -> b
$ DerivSpecVia { dsm_via_cls_tys :: [Type]
dsm_via_cls_tys = [Type]
cls_tys'
                          , dsm_via_inst_ty :: Type
dsm_via_inst_ty = Type
inst_ty'
                          , dsm_via_ty :: Type
dsm_via_ty      = Type
via_ty'
                          }

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). A DerivInstTys value can be seen
  as a more structured representation of the denv_inst_tys field of DerivEnv.

  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 StockGenFns -- Stock class, can derive
  | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it
  | CanDeriveAnyClass         -- See Note [Deriving any class]
  | NonDerivableClass -- Cannot derive with either stock or anyclass

-- | Describes how to generate instance bindings ('stock_gen_binds') and
-- associated type family instances ('stock_gen_fam_insts') for a particular
-- stock-derived instance.
data StockGenFns = StockGenFns
  { StockGenFns
-> SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
stock_gen_binds ::
         SrcSpan -> DerivInstTys
      -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
    -- ^ Describes how to generate instance bindings for a stock-derived
    -- instance.
    --
    -- This function takes two arguments:
    --
    -- 1. 'SrcSpan': the source location where the instance is being derived.
    --    This will eventually be instantiated with the 'ds_loc' field of a
    --    'DerivSpec'.
    --
    -- 2. 'DerivInstTys': information about the argument types to which a
    --    class is applied in a derived instance. This will eventually be
    --    instantiated with the 'dsm_stock_dit' field of a
    --    'DerivSpecMechanism'.
    --
    -- 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. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the
    --    derived instance. As examples, derived 'Eq' and 'Ord' instances
    --    sometimes 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]@.
  , StockGenFns -> SrcSpan -> DerivInstTys -> TcM [FamInst]
stock_gen_fam_insts ::
         SrcSpan -> DerivInstTys
      -> TcM [FamInst]
    -- ^ Describes how to generate associated type family instances for a
    -- stock-derived instance. This function takes the same arguments as the
    -- 'stock_gen_binds' function but returns a list of 'FamInst's instead.
    -- Generating type family instances is done separately from
    -- 'stock_gen_binds' since the type family instances must be generated
    -- before the instance bindings can be typechecked. See
    -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv".
  }

-- 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 'PredSpec' specifies a constraint to emitted when inferring the
-- instance context for a derived instance in 'GHC.Tc.Deriv.simplifyInfer'.
data PredSpec
  = -- | An ordinary 'PredSpec' that directly stores a 'PredType', which
    -- will be emitted as a wanted constraint in the constraint solving
    -- machinery. This is the simple case, as there are no skolems,
    -- metavariables, or given constraints involved.
    SimplePredSpec
      { PredSpec -> Type
sps_pred :: TcPredType
        -- ^ The constraint to emit as a wanted
      , PredSpec -> CtOrigin
sps_origin :: CtOrigin
        -- ^ The origin of the constraint
      , PredSpec -> TypeOrKind
sps_type_or_kind :: TypeOrKind
        -- ^ Whether the constraint is a type or kind
      }
  | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This
    -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic
    -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an
    -- implication constraint as a side effect. For more details on how this
    -- works, see @Note [Gathering and simplifying constraints for DeriveAnyClass]@
    -- in "GHC.Tc.Deriv.Infer".
    SubTypePredSpec
      { PredSpec -> Type
stps_ty_actual :: TcSigmaType
        -- ^ The actual type. In the context of @DeriveAnyClass@, this is the
        -- default method type signature.
      , PredSpec -> Type
stps_ty_expected :: TcSigmaType
        -- ^ The expected type. In the context of @DeriveAnyClass@, this is the
        -- original method type signature.
      , PredSpec -> CtOrigin
stps_origin :: CtOrigin
        -- ^ The origin of the constraint
      }

-- | A list of 'PredSpec' constraints to simplify when inferring a
-- derived instance's context. For the @stock@, @newtype@, and @via@ deriving
-- strategies, these will consist of 'SimplePredSpec's, and for
-- @DeriveAnyClass@, these will consist of 'SubTypePredSpec's. Here is an
-- example to illustrate the latter:
--
-- @
-- 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 'SubTypePredSpec's, one for each method:
--
-- @
-- [ SubTypePredSpec
--     { stps_ty_actual   = forall y. (Show (Quux q), Ix y) => Quux q -> y -> String
--     , stps_ty_expected = forall b.                (Ix b) => Quux q -> b -> String
--     , stps_ty_origin   = DerivClauseCtxt
--     }
-- , SubTypePredSpec
--     { stps_ty_actual   = Ord (Quux q) => Quux q -> Quux q -> Bool
--     , stps_ty_expected = Eq  (Quux q) => Quux q -> Quux q -> Bool
--     , stps_ty_origin   = DerivClauseCtxt
--     }
-- ]
-- @
--
-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
-- appears free in the 'stps_ty_actual's and 'stps_ty_expected's.)
--
-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
-- in "GHC.Tc.Deriv.Infer" for an explanation of how these 'SubTypePredSpec's
-- are used to compute implication constraints.
type ThetaSpec = [PredSpec]

instance Outputable PredSpec where
  ppr :: PredSpec -> SDoc
ppr (SimplePredSpec{sps_pred :: PredSpec -> Type
sps_pred = Type
ty}) =
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"SimplePredSpec")
       Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"sps_pred" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty ])
  ppr (SubTypePredSpec { stps_ty_actual :: PredSpec -> Type
stps_ty_actual = Type
ty_actual
                       , stps_ty_expected :: PredSpec -> Type
stps_ty_expected = Type
ty_expected }) =
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"SubTypePredSpec")
       Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"stps_ty_actual"   SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty_actual
               , String -> SDoc
text String
"stps_ty_expected" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty_expected
               ])

-- | Build a list of 'SimplePredSpec's, using the supplied 'CtOrigin' and
-- 'TypeOrKind' values for each 'PredType'.
mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaSpec
mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> [Type] -> ThetaSpec
mkDirectThetaSpec CtOrigin
origin TypeOrKind
t_or_k =
  (Type -> PredSpec) -> [Type] -> ThetaSpec
forall a b. (a -> b) -> [a] -> [b]
map (\Type
p -> SimplePredSpec
               { sps_pred :: Type
sps_pred = Type
p
               , sps_origin :: CtOrigin
sps_origin = CtOrigin
origin
               , sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
               })

substPredSpec :: HasCallStack => TCvSubst -> PredSpec -> PredSpec
substPredSpec :: HasCallStack => TCvSubst -> PredSpec -> PredSpec
substPredSpec TCvSubst
subst PredSpec
ps =
  case PredSpec
ps of
    SimplePredSpec { sps_pred :: PredSpec -> Type
sps_pred = Type
pred
                   , sps_origin :: PredSpec -> CtOrigin
sps_origin = CtOrigin
origin
                   , sps_type_or_kind :: PredSpec -> TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
                   }
      -> SimplePredSpec { sps_pred :: Type
sps_pred = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
pred
                        , sps_origin :: CtOrigin
sps_origin = CtOrigin
origin
                        , sps_type_or_kind :: TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
                        }

    SubTypePredSpec { stps_ty_actual :: PredSpec -> Type
stps_ty_actual = Type
ty_actual
                    , stps_ty_expected :: PredSpec -> Type
stps_ty_expected = Type
ty_expected
                    , stps_origin :: PredSpec -> CtOrigin
stps_origin = CtOrigin
origin
                    }
      -> SubTypePredSpec { stps_ty_actual :: Type
stps_ty_actual = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty_actual
                         , stps_ty_expected :: Type
stps_ty_expected = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty_expected
                         , stps_origin :: CtOrigin
stps_origin = CtOrigin
origin
                         }

-- | Capture wanted constraints from a 'ThetaSpec'.
captureThetaSpecConstraints ::
     UserTypeCtxt -- ^ Used to inform error messages as to whether
                  -- we are in a @deriving@ clause or a standalone
                  -- @deriving@ declaration
  -> ThetaSpec    -- ^ The specs from which constraints will be created
  -> TcM (TcLevel, WantedConstraints)
captureThetaSpecConstraints :: UserTypeCtxt -> ThetaSpec -> TcM (TcLevel, WantedConstraints)
captureThetaSpecConstraints UserTypeCtxt
user_ctxt ThetaSpec
theta =
  TcM WantedConstraints -> TcM (TcLevel, WantedConstraints)
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM WantedConstraints -> TcM (TcLevel, WantedConstraints))
-> TcM WantedConstraints -> TcM (TcLevel, WantedConstraints)
forall a b. (a -> b) -> a -> b
$ ThetaSpec -> TcM WantedConstraints
mk_wanteds ThetaSpec
theta
  where
    -- Create the constraints we need to solve. For stock and newtype
    -- deriving, these constraints will be simple wanted constraints
    -- like (C a, Ord b).
    -- But with DeriveAnyClass, we make an implication constraint.
    -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
    -- in GHC.Tc.Deriv.Infer.
    mk_wanteds :: ThetaSpec -> TcM WantedConstraints
    mk_wanteds :: ThetaSpec -> TcM WantedConstraints
mk_wanteds ThetaSpec
preds
      = do { (()
_, WantedConstraints
wanteds) <- TcM () -> TcM ((), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM () -> TcM ((), WantedConstraints))
-> TcM () -> TcM ((), WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                             (PredSpec -> TcM ()) -> ThetaSpec -> TcM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ PredSpec -> TcM ()
emit_constraints ThetaSpec
preds
           ; WantedConstraints -> TcM WantedConstraints
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WantedConstraints
wanteds }

    -- Emit the appropriate constraints depending on what sort of
    -- PredSpec we are dealing with.
    emit_constraints :: PredSpec -> TcM ()
    emit_constraints :: PredSpec -> TcM ()
emit_constraints PredSpec
ps =
      case PredSpec
ps of
        -- For constraints like (C a, Ord b), emit the
        -- constraints directly as simple wanted constraints.
        SimplePredSpec { sps_pred :: PredSpec -> Type
sps_pred = Type
wanted
                       , sps_origin :: PredSpec -> CtOrigin
sps_origin = CtOrigin
orig
                       , sps_type_or_kind :: PredSpec -> TypeOrKind
sps_type_or_kind = TypeOrKind
t_or_k
                       } -> do
          CtEvidence
ev <- CtOrigin -> Maybe TypeOrKind -> Type -> TcM CtEvidence
newWanted CtOrigin
orig (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
t_or_k) Type
wanted
          Ct -> TcM ()
emitSimple (CtEvidence -> Ct
mkNonCanonical CtEvidence
ev)

        -- For DeriveAnyClass, check if ty_actual is a subtype of
        -- ty_expected, which emits an implication constraint as a
        -- side effect. See
        -- Note [Gathering and simplifying constraints for DeriveAnyClass].
        -- in GHC.Tc.Deriv.Infer.
        SubTypePredSpec { stps_ty_actual :: PredSpec -> Type
stps_ty_actual   = Type
ty_actual
                        , stps_ty_expected :: PredSpec -> Type
stps_ty_expected = Type
ty_expected
                        , stps_origin :: PredSpec -> CtOrigin
stps_origin      = CtOrigin
orig
                        } -> do
          HsWrapper
_ <- CtOrigin -> UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubTypeSigma CtOrigin
orig UserTypeCtxt
user_ctxt Type
ty_actual Type
ty_expected
          () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-
************************************************************************
*                                                                      *
                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.
-}

hasStockDeriving
  :: Class -> Maybe StockGenFns
hasStockDeriving :: Class -> Maybe StockGenFns
hasStockDeriving Class
clas
  = Assoc Unique StockGenFns -> Unique -> Maybe StockGenFns
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe Assoc Unique StockGenFns
gen_list (Class -> Unique
forall a. Uniquable a => a -> Unique
getUnique Class
clas)
  where
    gen_list :: [(Unique, StockGenFns)]
    gen_list :: Assoc Unique StockGenFns
gen_list =
      [ (Unique
eqClassKey,          (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
gen_Eq_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
ordClassKey,         (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
gen_Ord_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
enumClassKey,        (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
gen_Enum_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
boundedClassKey,     (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Bounded_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
ixClassKey,          (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
gen_Ix_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
showClassKey,        (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (((Name -> Fixity)
 -> SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {t} {a} {c} {a}.
((Name -> Fixity) -> t -> DerivInstTys -> (a, c))
-> t
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
read_or_show_binds (Name -> Fixity)
-> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
(Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Show_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
readClassKey,        (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (((Name -> Fixity)
 -> SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {t} {a} {c} {a}.
((Name -> Fixity) -> t -> DerivInstTys -> (a, c))
-> t
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
read_or_show_binds (Name -> Fixity)
-> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
(Name -> Fixity)
-> SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Read_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
dataClassKey,        (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
gen_Data_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
functorClassKey,     (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Functor_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
foldableClassKey,    (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Foldable_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
traversableClassKey, (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Traversable_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
liftClassKey,        (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk ((SrcSpan
 -> DerivInstTys
 -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
     Bag AuxBindSpec))
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {m :: * -> *} {t} {t} {a} {c} {a} {a}.
Monad m =>
(t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
SrcSpan
-> DerivInstTys
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
gen_Lift_binds) SrcSpan -> DerivInstTys -> TcM [FamInst]
forall {f :: * -> *} {p} {p} {a}. Applicative f => p -> p -> f [a]
no_fam_insts)
      , (Unique
genClassKey,         (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (GenericKind
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {a}.
GenericKind
-> SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
generic_binds GenericKind
Gen0) (GenericKind -> SrcSpan -> DerivInstTys -> TcM [FamInst]
generic_fam_inst GenericKind
Gen0))
      , (Unique
gen1ClassKey,        (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk (GenericKind
-> SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall {a}.
GenericKind
-> SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
generic_binds GenericKind
Gen1) (GenericKind -> SrcSpan -> DerivInstTys -> TcM [FamInst]
generic_fam_inst GenericKind
Gen1))
      ]

    mk :: (SrcSpan
 -> DerivInstTys
 -> TcM
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name]))
-> (SrcSpan -> DerivInstTys -> TcM [FamInst]) -> StockGenFns
mk SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_binds_fn SrcSpan -> DerivInstTys -> TcM [FamInst]
gen_fam_insts_fn = StockGenFns
      { stock_gen_binds :: SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
stock_gen_binds     = SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
SrcSpan
-> DerivInstTys
-> TcM
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_binds_fn
      , stock_gen_fam_insts :: SrcSpan -> DerivInstTys -> TcM [FamInst]
stock_gen_fam_insts = SrcSpan -> DerivInstTys -> TcM [FamInst]
gen_fam_insts_fn
      }

    simple_binds :: (t -> t -> (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_binds t -> t -> (a, c)
gen_fn t
loc t
dit
      = let (a
binds, c
aux_specs) = t -> t -> (a, c)
gen_fn t
loc t
dit
        in (a, [a], c, [a]) -> m (a, [a], c, [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, [], c
aux_specs, [])

    -- 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.
    simple_bindsM :: (t -> t -> m (a, c)) -> t -> t -> m (a, [a], c, [a])
simple_bindsM t -> t -> m (a, c)
gen_fn t
loc t
dit
      = do { (a
binds, c
aux_specs) <- t -> t -> m (a, c)
gen_fn t
loc t
dit
           ; (a, [a], c, [a]) -> m (a, [a], c, [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, [], c
aux_specs, []) }

    read_or_show_binds :: ((Name -> Fixity) -> t -> DerivInstTys -> (a, c))
-> t
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) (a, [a], c, [Name])
read_or_show_binds (Name -> Fixity) -> t -> DerivInstTys -> (a, c)
gen_fn t
loc DerivInstTys
dit
      = do { let tc :: TyCon
tc = DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit
           ; Name -> Fixity
fix_env <- TyCon -> TcM (Name -> Fixity)
getDataConFixityFun TyCon
tc
           ; let (a
binds, c
aux_specs) = (Name -> Fixity) -> t -> DerivInstTys -> (a, c)
gen_fn Name -> Fixity
fix_env t
loc DerivInstTys
dit
                 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, [], c
aux_specs, [Name]
field_names) }

    generic_binds :: GenericKind
-> SrcSpan
-> DerivInstTys
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
generic_binds GenericKind
gk SrcSpan
loc DerivInstTys
dit
      = do { let tc :: TyCon
tc = DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit
           ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs) <- GenericKind
-> SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs])
gen_Generic_binds GenericKind
gk SrcSpan
loc DerivInstTys
dit
           ; let field_names :: [Name]
field_names = TyCon -> [Name]
all_field_names TyCon
tc
           ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag a, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, Bag a
forall a. Bag a
emptyBag, [Name]
field_names) }

    generic_fam_inst :: GenericKind -> SrcSpan -> DerivInstTys -> TcM [FamInst]
generic_fam_inst GenericKind
gk SrcSpan
loc DerivInstTys
dit
      = do { let tc :: TyCon
tc = DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit
           ; Name -> Fixity
fix_env <- TyCon -> TcM (Name -> Fixity)
getDataConFixityFun TyCon
tc
           ; FamInst
faminst <- GenericKind
-> (Name -> Fixity) -> SrcSpan -> DerivInstTys -> TcM FamInst
gen_Generic_fam_inst GenericKind
gk Name -> Fixity
fix_env SrcSpan
loc DerivInstTys
dit
           ; [FamInst] -> TcM [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [FamInst
faminst] }

    no_fam_insts :: p -> p -> f [a]
no_fam_insts p
_ p
_ = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    -- 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 [Unused constructors and deriving clauses] 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, #9830, and #20994
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 :: DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions dit :: DerivInstTys
dit@(DerivInstTys{dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys}) =
  do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls  = Class
cls
              , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt } <- ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
     DynFlags
dflags <- ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

     if    -- 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 DerivInstTys
dit of
             NotValid DeriveInstanceErrReason
err -> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginativeDerivStatus -> DerivM OriginativeDerivStatus)
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason -> OriginativeDerivStatus
StockClassError DeriveInstanceErrReason
err  -- Class-specific error
             Validity' DeriveInstanceErrReason
IsValid  |  [Type] -> Bool
forall a. [a] -> 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 StockGenFns
gen_fn <- Class -> Maybe StockGenFns
hasStockDeriving Class
cls
                      -> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginativeDerivStatus -> DerivM OriginativeDerivStatus)
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ StockGenFns -> OriginativeDerivStatus
CanDeriveStock StockGenFns
gen_fn
                      |  Bool
otherwise
                      -> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OriginativeDerivStatus -> DerivM OriginativeDerivStatus)
-> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason -> OriginativeDerivStatus
StockClassError (DeriveInstanceErrReason -> OriginativeDerivStatus)
-> DeriveInstanceErrReason -> OriginativeDerivStatus
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> DeriveInstanceErrReason
classArgsErr Class
cls [Type]
cls_tys
                        -- e.g. deriving( Eq s )

           -- ...if not, try falling back on DeriveAnyClass.
        |  Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags
        -> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OriginativeDerivStatus
CanDeriveAnyClass   -- DeriveAnyClass should work

        |  Bool
otherwise
        -> OriginativeDerivStatus -> DerivM OriginativeDerivStatus
forall a. a -> ReaderT DerivEnv (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OriginativeDerivStatus
NonDerivableClass -- Neither anyclass nor stock work


classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason
classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason
classArgsErr Class
cls [Type]
cls_tys = Type -> DeriveInstanceErrReason
DerivErrNotAClass (Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_tys)

-- 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

type Condition
   = DynFlags

  -> DerivInstTys -- ^ Information about the type arguments to the class.

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

andCond :: Condition -> Condition -> Condition
andCond :: Condition -> Condition -> Condition
andCond Condition
c1 Condition
c2 DynFlags
dflags DerivInstTys
dit
  = Condition
c1 DynFlags
dflags DerivInstTys
dit Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Condition
c2 DynFlags
dflags DerivInstTys
dit

-- | 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
           dit :: DerivInstTys
dit@(DerivInstTys{dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  = Validity' DeriveInstanceErrReason
valid_ADT Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' DeriveInstanceErrReason
valid_misc
  where
    valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason
    valid_ADT :: Validity' DeriveInstanceErrReason
valid_ADT
      | TyCon -> Bool
isAlgTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isDataFamilyTyCon TyCon
tc
      = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
      | Bool
otherwise
        -- Complain about functions, primitive types, and other tycons that
        -- stock deriving can't handle.
      = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid DeriveInstanceErrReason
DerivErrLastArgMustBeApp

    valid_misc :: Validity' DeriveInstanceErrReason
valid_misc
      = case DerivContext
deriv_ctxt of
         SupplyContext [Type]
_ -> Validity' DeriveInstanceErrReason
forall a. Validity' a
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons -- 1.
           , Bool -> Bool
not Bool
permissive
           , Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.EmptyDataDeriving DynFlags
dflags)
           -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (TyCon -> DeriveInstanceErrReason
no_cons_why TyCon
rep_tc)
           | Bool -> Bool
not ([DeriveInstanceBadConstructor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DeriveInstanceBadConstructor]
con_whys)
           -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor (HasWildcard -> Maybe HasWildcard
forall a. a -> Maybe a
Just (HasWildcard -> Maybe HasWildcard)
-> HasWildcard -> Maybe HasWildcard
forall a b. (a -> b) -> a -> b
$ Maybe SrcSpan -> HasWildcard
forall {a}. Maybe a -> HasWildcard
has_wildcard Maybe SrcSpan
wildcard) [DeriveInstanceBadConstructor]
con_whys
           | Bool
otherwise
           -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid

    has_wildcard :: Maybe a -> HasWildcard
has_wildcard Maybe a
wildcard
      = case Maybe a
wildcard of
          Just a
_  -> HasWildcard
YesHasWildcard
          Maybe a
Nothing -> HasWildcard
NoHasWildcard
    data_cons :: [DataCon]
data_cons  = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
    con_whys :: [DeriveInstanceBadConstructor]
con_whys   = [Validity' DeriveInstanceBadConstructor]
-> [DeriveInstanceBadConstructor]
forall a. [Validity' a] -> [a]
getInvalids ((DataCon -> Validity' DeriveInstanceBadConstructor)
-> [DataCon] -> [Validity' DeriveInstanceBadConstructor]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity' DeriveInstanceBadConstructor
check_con [DataCon]
data_cons)

    check_con :: DataCon -> Validity' DeriveInstanceBadConstructor
    check_con :: DataCon -> Validity' DeriveInstanceBadConstructor
check_con DataCon
con
      | Bool -> Bool
not ([EqSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec) -- 2.
      = (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConIsGADT
      | Bool -> Bool
not ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
ex_tvs) -- 3.
      = (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConHasExistentials
      | Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta) -- 4.
      = (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConHasConstraints
      | 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 (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
con DerivInstTys
dit)) -- 5.
      = (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
DerivErrBadConHasHigherRankType
      | Bool
otherwise
      = Validity' DeriveInstanceBadConstructor
forall a. Validity' a
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 :: (DataCon -> DeriveInstanceBadConstructor)
-> Validity' DeriveInstanceBadConstructor
bad DataCon -> DeriveInstanceBadConstructor
mkErr = DeriveInstanceBadConstructor
-> Validity' DeriveInstanceBadConstructor
forall a. a -> Validity' a
NotValid (DeriveInstanceBadConstructor
 -> Validity' DeriveInstanceBadConstructor)
-> DeriveInstanceBadConstructor
-> Validity' DeriveInstanceBadConstructor
forall a b. (a -> b) -> a -> b
$ DataCon -> DeriveInstanceBadConstructor
mkErr DataCon
con

no_cons_why :: TyCon -> DeriveInstanceErrReason
no_cons_why :: TyCon -> DeriveInstanceErrReason
no_cons_why = TyCon -> DeriveInstanceErrReason
DerivErrNoConstructors

cond_RepresentableOk :: Condition
cond_RepresentableOk :: Condition
cond_RepresentableOk DynFlags
_ DerivInstTys
dit =
  case DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics DerivInstTys
dit of
    Validity' [DeriveGenericsErrReason]
IsValid -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
    NotValid [DeriveGenericsErrReason]
generic_errs -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ [DeriveGenericsErrReason] -> DeriveInstanceErrReason
DerivErrGenerics [DeriveGenericsErrReason]
generic_errs

cond_Representable1Ok :: Condition
cond_Representable1Ok :: Condition
cond_Representable1Ok DynFlags
_ DerivInstTys
dit =
  case DerivInstTys -> Validity' [DeriveGenericsErrReason]
canDoGenerics1 DerivInstTys
dit of
    Validity' [DeriveGenericsErrReason]
IsValid -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
    NotValid [DeriveGenericsErrReason]
generic_errs -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ [DeriveGenericsErrReason] -> DeriveInstanceErrReason
DerivErrGenerics [DeriveGenericsErrReason]
generic_errs

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)
  where
    orCond :: Condition -> Condition -> Condition
    orCond :: Condition -> Condition -> Condition
orCond Condition
c1 Condition
c2 DynFlags
dflags DerivInstTys
dit
      = case (Condition
c1 DynFlags
dflags DerivInstTys
dit, Condition
c2 DynFlags
dflags DerivInstTys
dit) of
         (Validity' DeriveInstanceErrReason
IsValid,    Validity' DeriveInstanceErrReason
_)          -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid    -- c1 succeeds
         (Validity' DeriveInstanceErrReason
_,          Validity' DeriveInstanceErrReason
IsValid)    -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid    -- c21 succeeds
         (NotValid DeriveInstanceErrReason
x, NotValid DeriveInstanceErrReason
y) -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason
-> DeriveInstanceErrReason -> DeriveInstanceErrReason
DerivErrEnumOrProduct DeriveInstanceErrReason
x DeriveInstanceErrReason
y
                                                -- Both fail


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
_ dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  = case [Type]
bad_args of
      []     -> Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
      (Type
ty:[Type]
_) -> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Type -> DeriveInstanceErrReason
DerivErrDunnoHowToDeriveForType Type
ty
  where
    bad_args :: [Type]
bad_args = [ Type
arg_ty | DataCon
con <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
                        , Type
arg_ty <- DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
con DerivInstTys
dit
                        , Type -> Bool
mightBeUnliftedType Type
arg_ty
                        , 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, LHsExpr GhcPs -> LHsExpr GhcPs)]
[(Type,
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
  -> GenLocated SrcSpanAnnA (HsExpr GhcPs))]
boxConTbl
     | Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftClassKey = Bool
True     -- Lift is representation-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
_ (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  | TyCon -> Bool
isEnumerationTyCon TyCon
rep_tc = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
  | Bool
otherwise                 = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrMustBeEnumType TyCon
rep_tc

cond_isProduct :: Condition
cond_isProduct :: Condition
cond_isProduct DynFlags
_ (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  | Just DataCon
_ <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
rep_tc
  = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
  | Bool
otherwise
  = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrMustHaveExactlyOneConstructor TyCon
rep_tc

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
_
               dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  | [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tc_tvs
  = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrMustHaveSomeParameters TyCon
rep_tc

    -- We can't handle stupid contexts that mention the last type argument,
    -- so error out if we encounter one.
    -- See Note [The stupid context] in GHC.Core.DataCon.
  | Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_stupid_theta)
  = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> DeriveInstanceErrReason
DerivErrMustNotHaveClassContext TyCon
rep_tc [Type]
bad_stupid_theta

  | Bool
otherwise
  = [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
forall a. [Validity' a] -> Validity' a
allValid ((DataCon -> Validity' DeriveInstanceErrReason)
-> [DataCon] -> [Validity' DeriveInstanceErrReason]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity' DeriveInstanceErrReason
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. HasCallStack => [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' DeriveInstanceErrReason
check_con DataCon
con = [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
forall a. [Validity' a] -> Validity' a
allValid (DataCon -> Validity' DeriveInstanceErrReason
check_universal DataCon
con Validity' DeriveInstanceErrReason
-> [Validity' DeriveInstanceErrReason]
-> [Validity' DeriveInstanceErrReason]
forall a. a -> [a] -> [a]
: FFoldType (Validity' DeriveInstanceErrReason)
-> DataCon -> DerivInstTys -> [Validity' DeriveInstanceErrReason]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs (DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
ft_check DataCon
con) DataCon
con DerivInstTys
dit)

    check_universal :: DataCon -> Validity' DeriveInstanceErrReason
    check_universal :: DataCon -> Validity' DeriveInstanceErrReason
check_universal DataCon
con
      | Bool
allowExQuantifiedLastTyVar
      = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
                -- in GHC.Tc.Deriv.Functor
      | Just TyVar
tv <- Type -> Maybe TyVar
getTyVar_maybe ([Type] -> Type
forall a. HasCallStack => [a] -> a
last (HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs (DataCon -> Type
dataConOrigResTy DataCon
con)))
      , TyVar
tv TyVar -> [TyVar] -> Bool
forall a. Eq a => a -> [a] -> 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' DeriveInstanceErrReason
forall a. Validity' a
IsValid   -- See Note [Check that the type variable is truly universal]
      | Bool
otherwise
      = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConExistential DataCon
con]

    ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
    ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
ft_check DataCon
con = FT { ft_triv :: Validity' DeriveInstanceErrReason
ft_triv = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid, ft_var :: Validity' DeriveInstanceErrReason
ft_var = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
                      , ft_co_var :: Validity' DeriveInstanceErrReason
ft_co_var = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConCovariant DataCon
con]
                      , ft_fun :: Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
ft_fun = \Validity' DeriveInstanceErrReason
x Validity' DeriveInstanceErrReason
y -> if Bool
allowFunctions then Validity' DeriveInstanceErrReason
x Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
forall a. Validity' a -> Validity' a -> Validity' a
`andValid` Validity' DeriveInstanceErrReason
y
                                                           else DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConFunTypes DataCon
con]
                      , ft_tup :: TyCon
-> [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
ft_tup = \TyCon
_ [Validity' DeriveInstanceErrReason]
xs  -> [Validity' DeriveInstanceErrReason]
-> Validity' DeriveInstanceErrReason
forall a. [Validity' a] -> Validity' a
allValid [Validity' DeriveInstanceErrReason]
xs
                      , ft_ty_app :: Type
-> Type
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
ft_ty_app = \Type
_ Type
_ Validity' DeriveInstanceErrReason
x -> Validity' DeriveInstanceErrReason
x
                      , ft_bad_app :: Validity' DeriveInstanceErrReason
ft_bad_app = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid (DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason)
-> DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a b. (a -> b) -> a -> b
$ Maybe HasWildcard
-> [DeriveInstanceBadConstructor] -> DeriveInstanceErrReason
DerivErrBadConstructor Maybe HasWildcard
forall a. Maybe a
Nothing [DataCon -> DeriveInstanceBadConstructor
DerivErrBadConWrongArg DataCon
con]
                      , ft_forall :: TyVar
-> Validity' DeriveInstanceErrReason
-> Validity' DeriveInstanceErrReason
ft_forall = \TyVar
_ Validity' DeriveInstanceErrReason
x   -> Validity' DeriveInstanceErrReason
x }


checkFlag :: LangExt.Extension -> Condition
checkFlag :: Extension -> Condition
checkFlag Extension
flag DynFlags
dflags DerivInstTys
_
  | Extension -> DynFlags -> Bool
xopt Extension
flag DynFlags
dflags = Validity' DeriveInstanceErrReason
forall a. Validity' a
IsValid
  | Bool
otherwise        = DeriveInstanceErrReason -> Validity' DeriveInstanceErrReason
forall a. a -> Validity' a
NotValid DeriveInstanceErrReason
why
  where
    why :: DeriveInstanceErrReason
why = Extension -> DeriveInstanceErrReason
DerivErrLangExtRequired Extension
the_flag
    the_flag :: Extension
the_flag = case [ FlagSpec Extension -> Extension
forall flag. FlagSpec flag -> flag
flagSpecFlag 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
                 [Extension
s]   -> Extension
s
                 [Extension]
other -> String -> SDoc -> Extension
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkFlag" ([Extension] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Extension]
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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 ])

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

newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst
newDerivClsInst :: DerivSpec [Type] -> TcM ClsInst
newDerivClsInst (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_theta :: forall theta. DerivSpec theta -> theta
ds_theta = [Type]
theta
                    , 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.
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.
-}