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


Error-checking and other utilities for @deriving@ clauses or declarations.
-}

{-# LANGUAGE TypeFamilies #-}

module TcDerivUtils (
        DerivM, DerivEnv(..),
        DerivSpec(..), pprDerivSpec,
        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
        DerivContext(..), OriginativeDerivStatus(..),
        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
        checkOriginativeSideConditions, hasStockDeriving,
        canDeriveAnyClass,
        std_class_via_coercible, non_coercible_class,
        newDerivClsInst, extendLocalInstEnv
    ) where

import GhcPrelude

import Bag
import BasicTypes
import Class
import DataCon
import DynFlags
import ErrUtils
import HscTypes (lookupFixity, mi_fix)
import HsSyn
import Inst
import InstEnv
import LoadIface (loadInterfaceForName)
import Module (getModule)
import Name
import Outputable
import PrelNames
import SrcLoc
import TcGenDeriv
import TcGenFunctor
import TcGenGenerics
import TcRnMonad
import TcType
import THNames (liftClassKey)
import TyCon
import Type
import Util
import VarSet

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

-- | To avoid having to manually plumb everything in 'DerivEnv' throughout
-- various functions in @TcDeriv@ and @TcDerivInfer@, 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 wildcard :: 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 wildcard :: Maybe SrcSpan
wildcard) = Maybe SrcSpan -> Bool
forall a. Maybe a -> Bool
isJust Maybe SrcSpan
wildcard
    go (SupplyContext {})      = Bool
False

-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
mkDerivOrigin :: Bool -> CtOrigin
mkDerivOrigin :: Bool -> CtOrigin
mkDerivOrigin standalone_wildcard :: 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.
data DerivEnv = DerivEnv
  { DerivEnv -> Maybe OverlapMode
denv_overlap_mode :: Maybe OverlapMode
    -- ^ Is this an overlapping instance?
  , DerivEnv -> [TyVar]
denv_tvs          :: [TyVar]
    -- ^ Universally quantified type variables in the instance
  , DerivEnv -> Class
denv_cls          :: Class
    -- ^ Class for which we need to derive an instance
  , DerivEnv -> [Type]
denv_cls_tys      :: [Type]
    -- ^ Other arguments to the class except the last
  , DerivEnv -> TyCon
denv_tc           :: TyCon
    -- ^ Type constructor for which the instance is requested
    --   (last arguments to the type class)
  , DerivEnv -> [Type]
denv_tc_args      :: [Type]
    -- ^ Arguments to the type constructor
  , DerivEnv -> TyCon
denv_rep_tc       :: TyCon
    -- ^ The representation tycon for 'denv_tc'
    --   (for data family instances)
  , DerivEnv -> [Type]
denv_rep_tc_args  :: [Type]
    -- ^ The representation types for 'denv_tc_args'
    --   (for data family instances)
  , DerivEnv -> DerivContext
denv_ctxt         :: DerivContext
    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
    --   context of the instance).
    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
    --   uses a wildcard constraint.
    --   See @Note [Inferring the instance context]@.
  , DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat        :: Maybe (DerivStrategy GhcTc)
    -- ^ 'Just' if user requests a particular deriving strategy.
    --   Otherwise, 'Nothing'.
  }

instance Outputable DerivEnv where
  ppr :: DerivEnv -> SDoc
ppr (DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
                , denv_tvs :: DerivEnv -> [TyVar]
denv_tvs          = [TyVar]
tvs
                , denv_cls :: DerivEnv -> Class
denv_cls          = Class
cls
                , denv_cls_tys :: DerivEnv -> [Type]
denv_cls_tys      = [Type]
cls_tys
                , denv_tc :: DerivEnv -> TyCon
denv_tc           = TyCon
tc
                , denv_tc_args :: DerivEnv -> [Type]
denv_tc_args      = [Type]
tc_args
                , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc       = TyCon
rep_tc
                , denv_rep_tc_args :: DerivEnv -> [Type]
denv_rep_tc_args  = [Type]
rep_tc_args
                , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt         = DerivContext
ctxt
                , denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat        = Maybe (DerivStrategy GhcTc)
mb_strat })
    = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "DerivEnv")
         2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "denv_overlap_mode" SDoc -> SDoc -> SDoc
<+> Maybe OverlapMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe OverlapMode
overlap_mode
                 , String -> SDoc
text "denv_tvs"          SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
                 , String -> SDoc
text "denv_cls"          SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
                 , String -> SDoc
text "denv_cls_tys"      SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys
                 , String -> SDoc
text "denv_tc"           SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
                 , String -> SDoc
text "denv_tc_args"      SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tc_args
                 , String -> SDoc
text "denv_rep_tc"       SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
rep_tc
                 , String -> SDoc
text "denv_rep_tc_args"  SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
rep_tc_args
                 , String -> SDoc
text "denv_ctxt"         SDoc -> SDoc -> SDoc
<+> DerivContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivContext
ctxt
                 , String -> SDoc
text "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 { DerivSpec theta -> SrcSpan
ds_loc                 :: SrcSpan
                          , DerivSpec theta -> Name
ds_name                :: Name         -- DFun name
                          , DerivSpec theta -> [TyVar]
ds_tvs                 :: [TyVar]
                          , DerivSpec theta -> theta
ds_theta               :: theta
                          , DerivSpec theta -> Class
ds_cls                 :: Class
                          , DerivSpec theta -> [Type]
ds_tys                 :: [Type]
                          , DerivSpec theta -> TyCon
ds_tc                  :: TyCon
                          , DerivSpec theta -> Maybe OverlapMode
ds_overlap             :: Maybe OverlapMode
                          , DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard :: Maybe SrcSpan
                              -- See Note [Inferring the instance context]
                              -- in TcDerivInfer
                          , DerivSpec theta -> DerivSpecMechanism
ds_mechanism           :: DerivSpecMechanism }
        -- This spec implies a dfun declaration of the form
        --       df :: forall tvs. theta => C tys
        -- The Name is the name for the DFun we'll build
        -- The tyvars bind all the variables in the theta
        -- For type families, the tycon in
        --       in ds_tys is the *family* tycon
        --       in ds_tc is the *representation* type
        -- For non-family tycons, both are the same

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

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

{-
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_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
-}

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

-- What action to take in order to derive a class instance.
-- See Note [Deriving strategies] in TcDeriv
data DerivSpecMechanism
  = DerivSpecStock   -- "Standard" classes
      (SrcSpan -> TyCon
               -> [Type]
               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
      -- This function returns three things:
      --
      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
      --    (e.g., @compare (T x) (T y) = compare x y@)
      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived
      --    instance. As examples, derived 'Generic' instances require
      --    associated type family instances, and derived 'Eq' and 'Ord'
      --    instances require top-level @con2tag@ functions.
      --    See Note [Auxiliary binders] in TcGenDeriv.
      -- 3. @[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].

  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
      Type -- The newtype rep type

  | DerivSpecAnyClass -- -XDeriveAnyClass

  | DerivSpecVia -- -XDerivingVia
      Type -- The @via@ type

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

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

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

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

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

instance Outputable DerivSpecMechanism where
  ppr :: DerivSpecMechanism -> SDoc
ppr (DerivSpecStock{})   = String -> SDoc
text "DerivSpecStock"
  ppr (DerivSpecNewtype t :: Type
t) = String -> SDoc
text "DerivSpecNewtype" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t
  ppr DerivSpecAnyClass    = String -> SDoc
text "DerivSpecAnyClass"
  ppr (DerivSpecVia t :: Type
t)     = String -> SDoc
text "DerivSpecVia" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t

-- | 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 standalone :: Maybe SrcSpan
standalone) = String -> SDoc
text "InferContext"  SDoc -> SDoc -> SDoc
<+> Maybe SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe SrcSpan
standalone
  ppr (SupplyContext theta :: [Type]
theta)     = String -> SDoc
text "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 "TcDeriv".
data OriginativeDerivStatus
  = CanDeriveStock            -- Stock class, can derive
      (SrcSpan -> TyCon -> [Type]
               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
  | StockClassError SDoc      -- Stock class, but can't do it
  | CanDeriveAnyClass         -- See Note [Deriving any class]
  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass

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

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

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

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

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

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

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

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

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

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

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

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

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

    simple :: (t -> t -> (a, b)) -> t -> t -> p -> m (a, b, [a])
simple gen_fn :: t -> t -> (a, b)
gen_fn loc :: t
loc tc :: t
tc _
      = let (binds :: a
binds, deriv_stuff :: b
deriv_stuff) = t -> t -> (a, b)
gen_fn t
loc t
tc
        in (a, b, [a]) -> m (a, b, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, b
deriv_stuff, [])

    simpleM :: (t -> t -> m (a, b)) -> t -> t -> p -> m (a, b, [a])
simpleM gen_fn :: t -> t -> m (a, b)
gen_fn loc :: t
loc tc :: t
tc _
      = do { (binds :: a
binds, deriv_stuff :: b
deriv_stuff) <- t -> t -> m (a, b)
gen_fn t
loc t
tc
           ; (a, b, [a]) -> m (a, b, [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
binds, b
deriv_stuff, []) }

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

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

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

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

  module Main (main) where

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

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

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

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

See also Note [Newtype deriving and unused constructors] in TcDeriv 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. RnEnv.lookupFixity, and Trac #9830
getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
getDataConFixityFun tc :: TyCon
tc
  = do { Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; if Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name
         then do { FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
                 ; (Name -> Fixity) -> TcM (Name -> Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (FixityEnv -> Name -> Fixity
lookupFixity FixityEnv
fix_env) }
         else do { ModIface
iface <- SDoc -> Name -> TcRn ModIface
loadInterfaceForName SDoc
doc Name
name
                            -- Should already be loaded!
                 ; (Name -> Fixity) -> TcM (Name -> Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> OccName -> Fixity
mi_fix ModIface
iface (OccName -> Fixity) -> (Name -> OccName) -> Name -> Fixity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName) } }
  where
    name :: Name
name = TyCon -> Name
tyConName TyCon
tc
    doc :: SDoc
doc = String -> SDoc
text "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 TcDeriv for an explanation of what
-- "originative" means.
--
-- This is *apart* from the coerce-based strategies, newtype and via.
--
-- Here we get the representation tycon in case of family instances as it has
-- the data constructors - but we need to be careful to fall back to the
-- family tycon (with indexes) in error messages.

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

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

  | Bool
otherwise
  = OriginativeDerivStatus
CanDeriveAnyClass   -- DeriveAnyClass should work

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

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

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

type Condition
   = DynFlags

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

cond_args :: Class -> Condition
-- For some classes (eg Eq, Ord) we allow unlifted arg types
-- by generating specialised code.  For others (eg Data) we don't.
cond_args :: Class -> Condition
cond_args cls :: Class
cls _ _ rep_tc :: TyCon
rep_tc
  = case [Type]
bad_args of
      []     -> Validity
IsValid
      (ty :: Type
ty:_) -> SDoc -> Validity
NotValid (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Don't know how to derive" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls))
                             2 (String -> SDoc
text "for type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)))
  where
    bad_args :: [Type]
bad_args = [ Type
arg_ty | DataCon
con <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
                        , Type
arg_ty <- DataCon -> [Type]
dataConOrigArgTys DataCon
con
                        , HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType 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 arg_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, LHsExpr GhcPs -> LHsExpr GhcPs)] -> Bool
forall a. Type -> [(Type, a)] -> Bool
check_in Type
arg_ty [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
boxConTbl
     | Unique
cls_key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftClassKey = Type -> [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -> Bool
forall a. Type -> [(Type, a)] -> Bool
check_in Type
arg_ty [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl
     | Bool
otherwise               = Bool
False    -- Read, Ix etc

    check_in :: Type -> [(Type,a)] -> Bool
    check_in :: Type -> [(Type, a)] -> Bool
check_in arg_ty :: Type
arg_ty tbl :: [(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 _ _ rep_tc :: TyCon
rep_tc
  | TyCon -> Bool
isEnumerationTyCon TyCon
rep_tc = Validity
IsValid
  | Bool
otherwise                 = SDoc -> Validity
NotValid SDoc
why
  where
    why :: SDoc
why = [SDoc] -> SDoc
sep [ SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
rep_tc) SDoc -> SDoc -> SDoc
<+>
                  String -> SDoc
text "must be an enumeration type"
              , String -> SDoc
text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
                  -- See Note [Enumeration types] in TyCon

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

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

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

  | Bool
otherwise
  = [Validity] -> Validity
allValid ((DataCon -> Validity) -> [DataCon] -> [Validity]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Validity
check_con [DataCon]
data_cons)
  where
    tc_tvs :: [TyVar]
tc_tvs            = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
    Just (_, last_tv :: TyVar
last_tv) = [TyVar] -> Maybe ([TyVar], TyVar)
forall a. [a] -> Maybe ([a], a)
snocView [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 pred :: Type
pred       = TyVar
last_tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
pred
      -- See Note [Check that the type variable is truly universal]

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

This boilerplate code can be replaced by the more compact

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

if DeriveAnyClass is enabled.

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

Unfortunately, it is not clear how to determine the context (when using a
deriving clause; in standalone deriving, the user provides the context).
GHC uses the same heuristic for figuring out the class context that it uses for
Eq in the case of *-kinded classes, and for Functor in the case of
* -> *-kinded classes. That may not be optimal or even wrong. But in such
cases, standalone deriving can still be used.

Note [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 Trac #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 TcGenFunctor.

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
Trac #13813.
-}