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

-}


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

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Handles @deriving@ clauses on @data@ declarations.
module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where

import GHC.Prelude

import GHC.Hs
import GHC.Driver.Session

import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Deriv.Infer
import GHC.Tc.Deriv.Utils
import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
import GHC.Tc.Utils.Env
import GHC.Tc.Deriv.Generate
import GHC.Tc.Validity( checkValidInstHead )
import GHC.Core.InstEnv
import GHC.Tc.Utils.Instantiate
import GHC.Core.FamInstEnv
import GHC.Tc.Gen.HsType
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars )

import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Module ( addTcgDUs )
import GHC.Rename.Utils

import GHC.Core.Unify( tcUnifyTy )
import GHC.Core.Class
import GHC.Core.Type
import GHC.Utils.Error
import GHC.Core.DataCon
import GHC.Data.Maybe
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Set as NameSet
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Data.Bag
import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.BooleanFormula ( isUnsatisfied )

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List (partition, find)

{-
************************************************************************
*                                                                      *
                Overview
*                                                                      *
************************************************************************

Overall plan
~~~~~~~~~~~~
1.  Convert the decls (i.e. data/newtype deriving clauses,
    plus standalone deriving) to [EarlyDerivSpec]

2.  Infer the missing contexts for the InferTheta's

3.  Add the derived bindings, generating InstInfos
-}

data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)
                    | GivenTheta (DerivSpec ThetaType)
        -- InferTheta ds => the context for the instance should be inferred
        --      In this case ds_theta is the list of all the sets of
        --      constraints needed, such as (Eq [a], Eq a), together with a
        --      suitable CtLoc to get good error messages.
        --      The inference process is to reduce this to a
        --      simpler form (e.g. Eq a)
        --
        -- GivenTheta ds => the exact context for the instance is supplied
        --                  by the programmer; it is ds_theta
        -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer

splitEarlyDerivSpec :: [EarlyDerivSpec]
                    -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta DerivSpec ThetaSpec
spec : [EarlyDerivSpec]
specs) =
    case [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec ThetaSpec]
is, [DerivSpec [Type]]
gs) -> (DerivSpec ThetaSpec
spec DerivSpec ThetaSpec
-> [DerivSpec ThetaSpec] -> [DerivSpec ThetaSpec]
forall a. a -> [a] -> [a]
: [DerivSpec ThetaSpec]
is, [DerivSpec [Type]]
gs)
splitEarlyDerivSpec (GivenTheta DerivSpec [Type]
spec : [EarlyDerivSpec]
specs) =
    case [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec ThetaSpec]
is, [DerivSpec [Type]]
gs) -> ([DerivSpec ThetaSpec]
is, DerivSpec [Type]
spec DerivSpec [Type] -> [DerivSpec [Type]] -> [DerivSpec [Type]]
forall a. a -> [a] -> [a]
: [DerivSpec [Type]]
gs)

instance Outputable EarlyDerivSpec where
  ppr :: EarlyDerivSpec -> SDoc
ppr (InferTheta DerivSpec ThetaSpec
spec) = DerivSpec ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec ThetaSpec
spec SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(Infer)"
  ppr (GivenTheta DerivSpec [Type]
spec) = DerivSpec [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec [Type]
spec SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(Given)"

{-
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )

We will need an instance decl like:

        instance (Read a, RealFloat a) => Read (Complex a) where
          ...

The RealFloat in the context is because the read method for Complex is bound
to construct a Complex, and doing that requires that the argument type is
in RealFloat.

But this ain't true for Show, Eq, Ord, etc, since they don't construct
a Complex; they only take them apart.

Our approach: identify the offending classes, and add the data type
context to the instance decl.  The "offending classes" are

        Read, Enum?

FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
pattern matching against a constructor from a data type with a context
gives rise to the constraints for that context -- or at least the thinned
version.  So now all classes are "offending".

Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
    class C a b
    instance C [a] Char
    newtype T = T Char deriving( C [a] )

Notice the free 'a' in the deriving.  We have to fill this out to
    newtype T = T Char deriving( forall a. C [a] )

And then translate it to:
    instance C [a] Char => C [a] T where ...

Note [Unused constructors and deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #3221.  Consider
   data T = T1 | T2 deriving( Show )
Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
both of them.  So we gather defs/uses from deriving just like anything else.

-}

-- | Stuff needed to process a datatype's `deriving` clauses
data DerivInfo = DerivInfo { DerivInfo -> TyCon
di_rep_tc  :: TyCon
                             -- ^ The data tycon for normal datatypes,
                             -- or the *representation* tycon for data families
                           , DerivInfo -> [(Name, TyVar)]
di_scoped_tvs :: ![(Name,TyVar)]
                             -- ^ Variables that scope over the deriving clause.
                             -- See @Note [Scoped tyvars in a TcTyCon]@ in
                             -- "GHC.Core.TyCon".
                           , DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses :: [LHsDerivingClause GhcRn]
                           , DerivInfo -> SDoc
di_ctxt    :: SDoc -- ^ error context
                           }

{-

************************************************************************
*                                                                      *
Top-level function for \tr{derivings}
*                                                                      *
************************************************************************
-}

tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
  = TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (do { TcGblEnv
g <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
                 ; (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
g, Bag (InstInfo GhcRn)
forall a. Bag a
emptyBag, HsValBinds GhcRn
forall (a :: Pass) (b :: Pass).
HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsOut)}) (TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
 -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn))
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a b. (a -> b) -> a -> b
$
    do  { -- Fish the "deriving"-related information out of the GHC.Tc.Utils.Env
          -- And make the necessary "equations".
          [EarlyDerivSpec]
early_specs <- [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
        ; String -> SDoc -> TcRn ()
traceTc String
"tcDeriving" ([EarlyDerivSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EarlyDerivSpec]
early_specs)

        ; let ([DerivSpec ThetaSpec]
infer_specs, [DerivSpec [Type]]
given_specs) = [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [EarlyDerivSpec]
early_specs
        ; [FamInst]
famInsts1 <- (DerivSpec [Type] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [DerivSpec [Type]] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM DerivSpec [Type] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta.
DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts [DerivSpec [Type]]
given_specs
        ; [FamInst]
famInsts2 <- (DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [DerivSpec ThetaSpec] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta.
DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts [DerivSpec ThetaSpec]
infer_specs
        ; let famInsts :: [FamInst]
famInsts = [FamInst]
famInsts1 [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
famInsts2

        ; Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger

          -- We must put all the derived type family instances (from both
          -- infer_specs and given_specs) in the local instance environment
          -- before proceeding, or else simplifyInstanceContexts might
          -- get stuck if it has to reason about any of those family instances.
          -- See Note [Staging of tcDeriving]
        ; [FamInst]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv [FamInst]
famInsts (TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
 -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn))
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a b. (a -> b) -> a -> b
$
          -- NB: only call tcExtendLocalFamInstEnv once, as it performs
          -- validity checking for all of the family instances you give it.
          -- If the family instances have errors, calling it twice will result
          -- in duplicate error messages!

     do { [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
given_inst_binds <- (DerivSpec [Type]
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> [DerivSpec [Type]]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivSpec [Type]
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds [DerivSpec [Type]]
given_specs

        ; let given_inst_infos :: [InstInfo GhcPs]
given_inst_infos = ((InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs)
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])] -> [InstInfo GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs
forall a b c. (a, b, c) -> a
fstOf3 [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
given_inst_binds

        -- the stand-alone derived instances (@given_inst_infos@) are used when
        -- inferring the contexts for "deriving" clauses' instances
        -- (@infer_specs@)
        ; [DerivSpec [Type]]
final_infer_specs <-
            [ClsInst] -> TcM [DerivSpec [Type]] -> TcM [DerivSpec [Type]]
forall a. [ClsInst] -> TcM a -> TcM a
extendLocalInstEnv ((InstInfo GhcPs -> ClsInst) -> [InstInfo GhcPs] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcPs -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec [InstInfo GhcPs]
given_inst_infos) (TcM [DerivSpec [Type]] -> TcM [DerivSpec [Type]])
-> TcM [DerivSpec [Type]] -> TcM [DerivSpec [Type]]
forall a b. (a -> b) -> a -> b
$
            [DerivSpec ThetaSpec] -> TcM [DerivSpec [Type]]
simplifyInstanceContexts [DerivSpec ThetaSpec]
infer_specs
        ; [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
infer_inst_binds <- (DerivSpec [Type]
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> [DerivSpec [Type]]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivSpec [Type]
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds [DerivSpec [Type]]
final_infer_specs

        ; let ([InstInfo GhcPs]
_, [Bag AuxBindSpec]
aux_specs, [[Name]]
fvs) = [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
-> ([InstInfo GhcPs], [Bag AuxBindSpec], [[Name]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
given_inst_binds [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
forall a. [a] -> [a] -> [a]
++ [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
infer_inst_binds)
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; let aux_binds :: Bag (LHsBind GhcPs, LSig GhcPs)
aux_binds = SrcSpan -> Bag AuxBindSpec -> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds SrcSpan
loc ([Bag AuxBindSpec] -> Bag AuxBindSpec
forall a. [Bag a] -> Bag a
unionManyBags [Bag AuxBindSpec]
aux_specs)

        ; let infer_inst_infos :: [InstInfo GhcPs]
infer_inst_infos = ((InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs)
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])] -> [InstInfo GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs
forall a b c. (a, b, c) -> a
fstOf3 [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
infer_inst_binds
        ; let inst_infos :: [InstInfo GhcPs]
inst_infos = [InstInfo GhcPs]
given_inst_infos [InstInfo GhcPs] -> [InstInfo GhcPs] -> [InstInfo GhcPs]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcPs]
infer_inst_infos

        ; (Bag (InstInfo GhcRn)
inst_info, HsValBinds GhcRn
rn_aux_binds, DefUses
rn_dus) <- [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
aux_binds

        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag (InstInfo GhcRn) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (InstInfo GhcRn)
inst_info) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
             IO () -> TcRn ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_deriv String
"Derived instances"
                        DumpFormat
FormatHaskell
                        (Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> [FamInst] -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_info HsValBinds GhcRn
rn_aux_binds [FamInst]
famInsts))

        ; TcGblEnv
gbl_env <- [ClsInst]
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv ((InstInfo GhcRn -> ClsInst) -> [InstInfo GhcRn] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcRn -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_info))
                                          TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; let all_dus :: DefUses
all_dus = DefUses
rn_dus DefUses -> DefUses -> DefUses
`plusDU` Uses -> DefUses
usesOnly ([Name] -> Uses
NameSet.mkFVs ([Name] -> Uses) -> [Name] -> Uses
forall a b. (a -> b) -> a -> b
$ [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
fvs)
        ; (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs TcGblEnv
gbl_env DefUses
all_dus, Bag (InstInfo GhcRn)
inst_info, HsValBinds GhcRn
rn_aux_binds) } }
  where
    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
                   -> [FamInst]               -- Associated type family instances
                   -> SDoc
    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> [FamInst] -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_infos HsValBinds GhcRn
extra_binds [FamInst]
famInsts
      =    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Derived class instances:")
              Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((InstInfo GhcRn -> SDoc) -> [InstInfo GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcRn
i -> InstInfo GhcRn -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcRn
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"") (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_infos))
                 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
extra_binds)
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> SDoc -> SDoc
hangP (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Derived type family instances:")
             ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
pprRepTy [FamInst]
famInsts))

    hangP :: SDoc -> SDoc -> SDoc
hangP SDoc
s SDoc
x = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
s Int
2 SDoc
x

-- Prints the representable type family instance
pprRepTy :: FamInst -> SDoc
pprRepTy :: FamInst -> SDoc
pprRepTy fi :: FamInst
fi@(FamInst { fi_tys :: FamInst -> [Type]
fi_tys = [Type]
lhs })
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp (FamInst -> TyCon
famInstTyCon FamInst
fi) [Type]
lhs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
      SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs
  where rhs :: Type
rhs = FamInst -> Type
famInstRHS FamInst
fi

renameDeriv :: [InstInfo GhcPs]
            -> Bag (LHsBind GhcPs, LSig GhcPs)
            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
  = TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. TcRn a -> TcRn a
discardWarnings (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    -- Discard warnings about unused bindings etc
    Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.EmptyCase (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    -- Derived decls (for empty types) can have
    --    case x of {}
    Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ScopedTypeVariables (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.KindSignatures (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
    -- KindSignatures
    Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.TypeApplications (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    -- GND/DerivingVia uses TypeApplications in generated code
    -- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate)
    Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM Extension
LangExt.RebindableSyntax (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    -- See Note [Avoid RebindableSyntax when deriving]
    Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.TemplateHaskellQuotes (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    -- DeriveLift makes uses of quotes
    do  {
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
        ; String -> SDoc -> TcRn ()
traceTc String
"rnd" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((InstInfo GhcPs -> SDoc) -> [InstInfo GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcPs
i -> InstInfo GhcPs -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcPs
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"") [InstInfo GhcPs]
inst_infos))
        ; let (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
aux_binds, Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs) = Bag
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
   GenLocated SrcSpanAnnA (Sig GhcPs))
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag (GenLocated SrcSpanAnnA (Sig GhcPs)))
forall a b. Bag (a, b) -> (Bag a, Bag b)
unzipBag Bag (LHsBind GhcPs, LSig GhcPs)
Bag
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
   GenLocated SrcSpanAnnA (Sig GhcPs))
bagBinds
              aux_val_binds :: HsValBindsLR GhcPs GhcPs
aux_val_binds = XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
AnnSortKey
NoAnnSortKey LHsBindsLR GhcPs GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
aux_binds (Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs)
        -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
        -- auxiliary bindings as if they were defined locally.
        -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
        ; ([Name]
bndrs, HsValBindsLR GhcRn GhcPs
rn_aux_lhs) <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv HsValBindsLR GhcPs GhcPs
aux_val_binds
        ; [Name]
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
bndrs (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
 -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
    do  { (HsValBinds GhcRn
rn_aux, DefUses
dus_aux) <- Uses -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS ([Name] -> Uses
mkNameSet [Name]
bndrs) HsValBindsLR GhcRn GhcPs
rn_aux_lhs
        ; ([InstInfo GhcRn]
rn_inst_infos, [Uses]
fvs_insts) <- (InstInfo GhcPs
 -> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses))
-> [InstInfo GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) ([InstInfo GhcRn], [Uses])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info [InstInfo GhcPs]
inst_infos
        ; (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstInfo GhcRn] -> Bag (InstInfo GhcRn)
forall a. [a] -> Bag a
listToBag [InstInfo GhcRn]
rn_inst_infos, HsValBinds GhcRn
rn_aux,
                  DefUses
dus_aux DefUses -> DefUses -> DefUses
`plusDU` Uses -> DefUses
usesOnly ([Uses] -> Uses
plusFVs [Uses]
fvs_insts)) } }

  where
    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
    rn_inst_info :: InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info
      inst_info :: InstInfo GhcPs
inst_info@(InstInfo { iSpec :: forall a. InstInfo a -> ClsInst
iSpec = ClsInst
inst
                          , iBinds :: forall a. InstInfo a -> InstBindings a
iBinds = InstBindings
                            { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBindsLR GhcPs GhcPs
binds
                            , ib_tyvars :: forall a. InstBindings a -> [Name]
ib_tyvars = [Name]
tyvars
                            , ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig GhcPs]
sigs
                            , ib_extensions :: forall a. InstBindings a -> [Extension]
ib_extensions = [Extension]
exts -- Only for type-checking
                            , ib_derived :: forall a. InstBindings a -> Bool
ib_derived = Bool
sa } })
        =  do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
rn_binds, [GenLocated SrcSpanAnnA (Sig GhcRn)]
rn_sigs, Uses
fvs) <- Bool
-> Name
-> [Name]
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], Uses)
rnMethodBinds Bool
False (ClsInst -> Name
is_cls_nm ClsInst
inst)
                                                          [Name]
tyvars LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs
              ; let binds' :: InstBindings GhcRn
binds' = InstBindings { ib_binds :: LHsBinds GhcRn
ib_binds = LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
rn_binds
                                          , ib_tyvars :: [Name]
ib_tyvars = [Name]
tyvars
                                          , ib_pragmas :: [LSig GhcRn]
ib_pragmas = [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
rn_sigs
                                          , ib_extensions :: [Extension]
ib_extensions = [Extension]
exts
                                          , ib_derived :: Bool
ib_derived = Bool
sa }
              ; (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs
inst_info { iBinds = binds' }, Uses
fvs) }

{-
Note [Staging of tcDeriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a tricky corner case for deriving (adapted from #2721):

    class C a where
      type T a
      foo :: a -> T a

    instance C Int where
      type T Int = Int
      foo = id

    newtype N = N Int deriving C

This will produce an instance something like this:

    instance C N where
      type T N = T Int
      foo = coerce (foo :: Int -> T Int) :: N -> T N

We must be careful in order to typecheck this code. When determining the
context for the instance (in simplifyInstanceContexts), we need to determine
that T N and T Int have the same representation, but to do that, the T N
instance must be in the local family instance environment. Otherwise, GHC
would be unable to conclude that T Int is representationally equivalent to
T Int, and simplifyInstanceContexts would get stuck.

Previously, tcDeriving would defer adding any derived type family instances to
the instance environment until the very end, which meant that
simplifyInstanceContexts would get called without all the type family instances
it needed in the environment in order to properly simplify instance like
the C N instance above.

To avoid this scenario, we generate things in tcDeriving in a specific order:

1. First, we generate all of the associated type family instances for derived
   instances (using `genFamInsts`).
2. Next, we extend the local instance environment with these type family
   instances.
3. Then, we generate the instance bindings for derived instances
   (using `genInstBinds`).
4. Finally, for instances generated with `deriving` clauses, we infer the
   instance contexts (using `simplifyInstanceContexts`). At this point, we
   already have the necessary type family instances in scope (from step (2)),
   so this is safe to do.

Note [Why we don't pass rep_tc into deriveTyData]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc
back into the rep_tc by means of a lookup. And yet we have the rep_tc right
here! Why look it up again? Answer: it's just easier this way.
We drop some number of arguments from the end of the datatype definition
in deriveTyData. The arguments are dropped from the fam_tc.
This action may drop a *different* number of arguments
passed to the rep_tc, depending on how many free variables, etc., the
dropped patterns have.

Also, this technique carries over the kind substitution from deriveTyData
nicely.

Note [Avoid RebindableSyntax when deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The RebindableSyntax extension interacts awkwardly with the derivation of
any stock class whose methods require the use of string literals. The Show
class is a simple example (see #12688):

  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
  newtype Text = Text String
  fromString :: String -> Text
  fromString = Text

  data Foo = Foo deriving Show

This will generate code to the effect of:

  instance Show Foo where
    showsPrec _ Foo = showString "Foo"

But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
string literal is now of type Text, not String, which showString doesn't
accept! This causes the generated Show instance to fail to typecheck.

To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
in derived code.

************************************************************************
*                                                                      *
                From HsSyn to DerivSpec
*                                                                      *
************************************************************************

@makeDerivSpecs@ fishes around to find the info about needed derived instances.
-}

makeDerivSpecs :: [DerivInfo]
               -> [LDerivDecl GhcRn]
               -> TcM [EarlyDerivSpec]
makeDerivSpecs :: [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
  = do  { [[EarlyDerivSpec]]
eqns1 <- [TcM [EarlyDerivSpec]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[EarlyDerivSpec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
                      -- MP: scoped_tvs here magically converts TyVar into TcTyVar
                     [ TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
dcs (LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds LDerivClauseTys GhcRn
dct) SDoc
err_ctxt
                     | DerivInfo { di_rep_tc :: DerivInfo -> TyCon
di_rep_tc = TyCon
rep_tc
                                 , di_scoped_tvs :: DerivInfo -> [(Name, TyVar)]
di_scoped_tvs = [(Name, TyVar)]
scoped_tvs
                                 , di_clauses :: DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses = [LHsDerivingClause GhcRn]
clauses
                                 , di_ctxt :: DerivInfo -> SDoc
di_ctxt = SDoc
err_ctxt } <- [DerivInfo]
deriv_infos
                     , L SrcAnn NoEpAnns
_ (HsDerivingClause { deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_strategy = Maybe (LDerivStrategy GhcRn)
dcs
                                             , deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys = LDerivClauseTys GhcRn
dct })
                         <- [LHsDerivingClause GhcRn]
[GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
clauses
                     ]
        ; [Maybe EarlyDerivSpec]
eqns2 <- (GenLocated SrcSpanAnnA (DerivDecl GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [GenLocated SrcSpanAnnA (DerivDecl GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe EarlyDerivSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EarlyDerivSpec
forall a. Maybe a
Nothing) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> (GenLocated SrcSpanAnnA (DerivDecl GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone) [LDerivDecl GhcRn]
[GenLocated SrcSpanAnnA (DerivDecl GhcRn)]
deriv_decls
        ; [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ [[EarlyDerivSpec]] -> [EarlyDerivSpec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EarlyDerivSpec]]
eqns1 [EarlyDerivSpec] -> [EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [a] -> [a] -> [a]
++ [Maybe EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [Maybe a] -> [a]
catMaybes [Maybe EarlyDerivSpec]
eqns2 }
  where
    deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
    deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds (L SrcSpanAnnC
_ DerivClauseTys GhcRn
dct) = case DerivClauseTys GhcRn
dct of
      DctSingle XDctSingle GhcRn
_ LHsSigType GhcRn
ty -> [LHsSigType GhcRn
ty]
      DctMulti XDctMulti GhcRn
_ [LHsSigType GhcRn]
tys -> [LHsSigType GhcRn]
tys

------------------------------------------------------------------
-- | Process the derived classes in a single @deriving@ clause.
deriveClause :: TyCon
             -> [(Name, TcTyVar)]  -- Scoped type variables taken from tcTyConScopedTyVars
                                   -- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon"
             -> Maybe (LDerivStrategy GhcRn)
             -> [LHsSigType GhcRn] -> SDoc
             -> TcM [EarlyDerivSpec]
deriveClause :: TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat [LHsSigType GhcRn]
deriv_preds SDoc
err_ctxt
  = SDoc -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
      String -> SDoc -> TcRn ()
traceTc String
"deriveClause" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tvs"             SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"scoped_tvs"      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
scoped_tvs
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc"              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tys"             SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mb_lderiv_strat ]
      [(Name, TyVar)] -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
scoped_tvs (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
        (Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat', [TyVar]
via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
        [TyVar] -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
via_tvs (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$
        -- Moreover, when using DerivingVia one can bind type variables in
        -- the `via` type as well, so these type variables must also be
        -- brought into scope.
          (GenLocated SrcSpanAnnA (HsSigType GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> TcM [EarlyDerivSpec]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (TyCon
-> [Type]
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc [Type]
tys Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat' [TyVar]
via_tvs) [LHsSigType GhcRn]
[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
deriv_preds
          -- After typechecking the `via` type once, we then typecheck all
          -- of the classes associated with that `via` type in the
          -- `deriving` clause.
          -- See also Note [Don't typecheck too much in DerivingVia].
  where
    tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
    (TyCon
tc, [Type]
tys) = case TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
rep_tc of
                        -- data family:
                  Just (TyCon
fam_tc, [Type]
pats, CoAxiom Unbranched
_) -> (TyCon
fam_tc, [Type]
pats)
      -- NB: deriveTyData wants the *user-specified*
      -- name. See Note [Why we don't pass rep_tc into deriveTyData]

                  Maybe (TyCon, [Type], CoAxiom Unbranched)
_ -> (TyCon
rep_tc, [TyVar] -> [Type]
mkTyVarTys [TyVar]
tvs)     -- datatype

-- | Process a single predicate in a @deriving@ clause.
--
-- This returns a 'Maybe' because the user might try to derive 'Typeable',
-- which is a no-op nowadays.
derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]
           -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)
derivePred :: TyCon
-> [Type]
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc [Type]
tys Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat [TyVar]
via_tvs LHsSigType GhcRn
deriv_pred =
  -- We carefully set up uses of recoverM to minimize error message
  -- cascades. See Note [Recovering from failures in deriving clauses].
  IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EarlyDerivSpec
forall a. Maybe a
Nothing) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
  SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$ do
    String -> SDoc -> TcRn ()
traceTc String
"derivePred" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
      [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc"              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
      , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tys"             SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
      , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"deriv_pred"      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred
      , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat
      , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via_tvs"         SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
via_tvs ]
    ([TyVar]
cls_tvs, Class
cls, [Type]
cls_tys, [Type]
cls_arg_kinds) <- LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Type])
tcHsDeriv LHsSigType GhcRn
deriv_pred
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Type]
cls_arg_kinds [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIsNot` Int
1) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
      TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (LHsSigType GhcRn -> TcRnMessage
TcRnNonUnaryTypeclassConstraint LHsSigType GhcRn
deriv_pred)
    let [Type
cls_arg_kind] = [Type]
cls_arg_kinds
        mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat = (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
 -> DerivStrategy GhcTc)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat
    if (Class -> Name
className Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName)
    then do TcRn ()
warnUselessTypeable
            Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing
    else let deriv_tvs :: [TyVar]
deriv_tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs in
         EarlyDerivSpec -> Maybe EarlyDerivSpec
forall a. a -> Maybe a
Just (EarlyDerivSpec -> Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [Type]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc [Type]
tys Maybe (DerivStrategy GhcTc)
mb_deriv_strat
                               [TyVar]
deriv_tvs Class
cls [Type]
cls_tys Type
cls_arg_kind

{-
Note [Don't typecheck too much in DerivingVia]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following example:

  data D = ...
    deriving (A1 t, ..., A20 t) via T t

GHC used to be engineered such that it would typecheck the `deriving`
clause like so:

1. Take the first class in the clause (`A1`).
2. Typecheck the `via` type (`T t`) and bring its bound type variables
   into scope (`t`).
3. Typecheck the class (`A1`).
4. Move on to the next class (`A2`) and repeat the process until all
   classes have been typechecked.

This algorithm gets the job done most of the time, but it has two notable
flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked
20 different times, once for each class in the `deriving` clause. This is
unnecessary because we only need to typecheck `T t` once in order to get
access to its bound type variable.

The other issue with this algorithm arises when there are no classes in the
`deriving` clause, like in the following example:

  data D2 = ...
    deriving () via Maybe Maybe

Because there are no classes, the algorithm above will simply do nothing.
As a consequence, GHC will completely miss the fact that `Maybe Maybe`
is ill-kinded nonsense (#16923).

To address both of these problems, GHC now uses this algorithm instead:

1. Typecheck the `via` type and bring its bound type variables into scope.
2. Take the first class in the `deriving` clause.
3. Typecheck the class.
4. Move on to the next class and repeat the process until all classes have been
   typechecked.

This algorithm ensures that the `via` type is always typechecked, even if there
are no classes in the `deriving` clause. Moreover, it typecheck the `via` type
/exactly/ once and no more, even if there are multiple classes in the clause.

Note [Recovering from failures in deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider what happens if you run this program (from #10684) without
DeriveGeneric enabled:

    data A = A deriving (Show, Generic)
    data B = B A deriving (Show)

Naturally, you'd expect GHC to give an error to the effect of:

    Can't make a derived instance of `Generic A':
      You need -XDeriveGeneric to derive an instance for this class

And *only* that error, since the other two derived Show instances appear to be
independent of this derived Generic instance. Yet GHC also used to give this
additional error on the program above:

    No instance for (Show A)
      arising from the 'deriving' clause of a data type declaration
    When deriving the instance for (Show B)

This was happening because when GHC encountered any error within a single
data type's set of deriving clauses, it would call recoverM and move on
to the next data type's deriving clauses. One unfortunate consequence of
this design is that if A's derived Generic instance failed, its derived
Show instance would be skipped entirely, leading to the "No instance for
(Show A)" error cascade.

The solution to this problem is to push through uses of recoverM to the
level of the individual derived classes in a particular data type's set of
deriving clauses. That is, if you have:

    newtype C = C D
      deriving (E, F, G)

Then instead of processing instances E through M under the scope of a single
recoverM, as in the following pseudocode:

  recoverM (pure Nothing) $ mapM derivePred [E, F, G]

We instead use recoverM in each iteration of the loop:

  mapM (recoverM (pure Nothing) . derivePred) [E, F, G]

And then process each class individually, under its own recoverM scope. That
way, failure to derive one class doesn't cancel out other classes in the
same set of clause-derived classes.
-}

------------------------------------------------------------------
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
-- Process a single standalone deriving declaration
--  e.g.   deriving instance Show a => Show (T a)
-- Rather like tcLocalInstDecl
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
deriveStandalone :: LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone (L SrcSpanAnnA
loc (DerivDecl XCDerivDecl GhcRn
_ LHsSigWcType GhcRn
deriv_ty Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat Maybe (XRec GhcRn OverlapMode)
overlap_mode))
  = SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc                       (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
    SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
deriv_ty)  (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving decl for" (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
deriv_ty)
       ; let ctxt :: UserTypeCtxt
ctxt = Bool -> UserTypeCtxt
GHC.Tc.Types.Origin.InstDeclCtxt Bool
True
       ; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (standalone deriving)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mb_lderiv_strat, HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
deriv_ty]
       ; (Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat, [TyVar]
via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
       ; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (standalone deriving) 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
via_tvs]
       ; ([TyVar]
cls_tvs, DerivContext
deriv_ctxt, Class
cls, [Type]
inst_tys)
           <- [TyVar]
-> TcM ([TyVar], DerivContext, Class, [Type])
-> TcM ([TyVar], DerivContext, Class, [Type])
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
via_tvs (TcM ([TyVar], DerivContext, Class, [Type])
 -> TcM ([TyVar], DerivContext, Class, [Type]))
-> TcM ([TyVar], DerivContext, Class, [Type])
-> TcM ([TyVar], DerivContext, Class, [Type])
forall a b. (a -> b) -> a -> b
$
              UserTypeCtxt
-> LHsSigWcType GhcRn -> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType UserTypeCtxt
ctxt LHsSigWcType GhcRn
deriv_ty
       ; let mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat = (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
 -> DerivStrategy GhcTc)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat
             tvs :: [TyVar]
tvs            = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs
         -- See Note [Unify kinds in deriving]
       ; ([TyVar]
tvs', DerivContext
deriv_ctxt', [Type]
inst_tys', Maybe (DerivStrategy GhcTc)
mb_deriv_strat') <-
           case Maybe (DerivStrategy GhcTc)
mb_deriv_strat of
             -- Perform an additional unification with the kind of the `via`
             -- type and the result of the previous kind unification.
             Just (ViaStrategy XViaStrategy GhcTc
via_ty)
                  -- This unification must be performed on the last element of
                  -- inst_tys, but we have not yet checked for this property.
                  -- (This is done later in expectNonNullaryClsArgs). For now,
                  -- simply do nothing if inst_tys is empty, since
                  -- expectNonNullaryClsArgs will error later if this
                  -- is the case.
               |  Just Type
inst_ty <- [Type] -> Maybe Type
forall a. [a] -> Maybe a
lastMaybe [Type]
inst_tys
               -> do
               let via_kind :: Type
via_kind     = HasDebugCallStack => Type -> Type
Type -> Type
typeKind XViaStrategy GhcTc
Type
via_ty
                   inst_ty_kind :: Type
inst_ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
inst_ty
                   mb_match :: Maybe Subst
mb_match     = Type -> Type -> Maybe Subst
tcUnifyTy Type
inst_ty_kind Type
via_kind

               Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
mb_match)
                       (Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                          Type -> Type -> Type -> DeriveInstanceErrReason
DerivErrDerivingViaWrongKind Type
inst_ty_kind XViaStrategy GhcTc
Type
via_ty Type
via_kind)

               let Just Subst
kind_subst = Maybe Subst
mb_match
                   ki_subst_range :: VarSet
ki_subst_range  = Subst -> VarSet
getSubstRangeTyCoFVs Subst
kind_subst
                   -- See Note [Unification of two kind variables in deriving]
                   unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> Subst -> Bool
`notElemSubst` Subst
kind_subst
                                        Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
                                          [TyVar]
tvs
                   (Subst
subst, [TyVar]
_)    = HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar])
Subst -> [TyVar] -> (Subst, [TyVar])
substTyVarBndrs Subst
kind_subst [TyVar]
unmapped_tkvs
                   (DerivContext
final_deriv_ctxt, [Type]
final_deriv_ctxt_tys)
                     = case DerivContext
deriv_ctxt of
                         InferContext Maybe SrcSpan
wc -> (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
wc, [])
                         SupplyContext [Type]
theta ->
                           let final_theta :: [Type]
final_theta = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTheta Subst
subst [Type]
theta
                           in ([Type] -> DerivContext
SupplyContext [Type]
final_theta, [Type]
final_theta)
                   final_inst_tys :: [Type]
final_inst_tys   = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
inst_tys
                   final_via_ty :: Type
final_via_ty     = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy  Subst
subst XViaStrategy GhcTc
Type
via_ty
                   -- See Note [Floating `via` type variables]
                   final_tvs :: [TyVar]
final_tvs        = [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped ([Type] -> [TyVar]) -> [Type] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
                                      [Type]
final_deriv_ctxt_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
final_inst_tys
                                        [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
final_via_ty]
               ([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
final_tvs, DerivContext
final_deriv_ctxt, [Type]
final_inst_tys
                    , DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a. a -> Maybe a
Just (XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcTc
Type
final_via_ty) )

             Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, DerivContext
deriv_ctxt, [Type]
inst_tys, Maybe (DerivStrategy GhcTc)
mb_deriv_strat)
       ; String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving;" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
              [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tvs':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs'
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mb_deriv_strat':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"deriv_ctxt':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DerivContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivContext
deriv_ctxt'
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inst_tys':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
inst_tys' ]
                -- C.f. GHC.Tc.TyCl.Instance.tcLocalInstDecl1

       ; if Class -> Name
className Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName
         then do TcRn ()
warnUselessTypeable
                 Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing
         else EarlyDerivSpec -> Maybe EarlyDerivSpec
forall a. a -> Maybe a
Just (EarlyDerivSpec -> Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe OverlapMode
-> [TyVar]
-> Class
-> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp ((GenLocated SrcSpanAnnP OverlapMode -> OverlapMode)
-> Maybe (GenLocated SrcSpanAnnP OverlapMode) -> Maybe OverlapMode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP OverlapMode -> OverlapMode
forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn OverlapMode)
Maybe (GenLocated SrcSpanAnnP OverlapMode)
overlap_mode)
                                 [TyVar]
tvs' Class
cls [Type]
inst_tys'
                                 DerivContext
deriv_ctxt' Maybe (DerivStrategy GhcTc)
mb_deriv_strat' }

-- Typecheck the type in a standalone deriving declaration.
--
-- This may appear dense, but it's mostly huffing and puffing to recognize
-- the special case of a type with an extra-constraints wildcard context, e.g.,
--
--   deriving instance _ => Eq (Foo a)
--
-- If there is such a wildcard, we typecheck this as if we had written
-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
-- as the 'DerivContext', where loc is the location of the wildcard used for
-- error reporting. This indicates that we should infer the context as if we
-- were deriving Eq via a deriving clause
-- (see Note [Inferring the instance context] in GHC.Tc.Deriv.Infer).
--
-- If there is no wildcard, then proceed as normal, and instead return
-- @'SupplyContext' theta@, where theta is the typechecked context.
--
-- Note that this will never return @'InferContext' 'Nothing'@, as that can
-- only happen with @deriving@ clauses.
tcStandaloneDerivInstType
  :: UserTypeCtxt -> LHsSigWcType GhcRn
  -> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType :: UserTypeCtxt
-> LHsSigWcType GhcRn -> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType UserTypeCtxt
ctxt
    (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = deriv_ty :: LHsSigType GhcRn
deriv_ty@(L SrcSpanAnnA
loc (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
                                               , sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
deriv_ty_body }))})
  | (Maybe (LHsContext GhcRn)
theta, LHsType GhcRn
rho) <- LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
deriv_ty_body
  , [LHsType GhcRn
wc_pred] <- Maybe (LHsContext GhcRn) -> [LHsType GhcRn]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
theta
  , L SrcSpanAnnA
wc_span (HsWildCardTy XWildCardTy GhcRn
_) <- LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens LHsType GhcRn
wc_pred
  = do Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt (LHsSigType GhcRn -> TcM Type) -> LHsSigType GhcRn -> TcM Type
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$
                  HsSig { sig_ext :: XHsSig GhcRn
sig_ext   = XHsSig GhcRn
NoExtField
noExtField
                        , sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
                        , sig_body :: LHsType GhcRn
sig_body  = LHsType GhcRn
rho }
       let ([TyVar]
tvs, [Type]
_theta, Class
cls, [Type]
inst_tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy Type
dfun_ty
       ([TyVar], DerivContext, Class, [Type])
-> TcM ([TyVar], DerivContext, Class, [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, Maybe SrcSpan -> DerivContext
InferContext (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
wc_span)), Class
cls, [Type]
inst_tys)
  | Bool
otherwise
  = do Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt LHsSigType GhcRn
deriv_ty
       let ([TyVar]
tvs, [Type]
theta, Class
cls, [Type]
inst_tys) = Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy Type
dfun_ty
       ([TyVar], DerivContext, Class, [Type])
-> TcM ([TyVar], DerivContext, Class, [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, [Type] -> DerivContext
SupplyContext [Type]
theta, Class
cls, [Type]
inst_tys)

warnUselessTypeable :: TcM ()
warnUselessTypeable :: TcRn ()
warnUselessTypeable = TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
TcRnUselessTypeable

------------------------------------------------------------------
deriveTyData :: TyCon -> [Type] -- LHS of data or data instance
                    -- Can be a data instance, hence [Type] args
                    -- and in that case the TyCon is the /family/ tycon
             -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy
             -> [TyVar] -- The type variables bound by the derived class
             -> Class   -- The derived class
             -> [Type]  -- The derived class's arguments
             -> Kind    -- The function argument in the derived class's kind.
                        -- (e.g., if `deriving Functor`, this would be
                        -- `Type -> Type` since
                        -- `Functor :: (Type -> Type) -> Constraint`)
             -> TcM EarlyDerivSpec
-- The deriving clause of a data or newtype declaration
-- I.e. not standalone deriving
deriveTyData :: TyCon
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [Type]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc [Type]
tc_args Maybe (DerivStrategy GhcTc)
mb_deriv_strat [TyVar]
deriv_tvs Class
cls [Type]
cls_tys Type
cls_arg_kind
   = do {  -- Given data T a b c = ... deriving( C d ),
           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
          let ([Scaled Type]
arg_kinds, Type
_)  = Type -> ([Scaled Type], Type)
splitFunTys Type
cls_arg_kind
              n_args_to_drop :: Int
n_args_to_drop  = [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
arg_kinds
              n_args_to_keep :: Int
n_args_to_keep  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tc_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args_to_drop
                                -- See Note [tc_args and tycon arity]
              ([Type]
tc_args_to_keep, [Type]
args_to_drop)
                              = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_args_to_keep [Type]
tc_args
              inst_ty_kind :: Type
inst_ty_kind    = HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args_to_keep)

              -- Match up the kinds, and apply the resulting kind substitution
              -- to the types.  See Note [Unify kinds in deriving]
              -- We are assuming the tycon tyvars and the class tyvars are distinct
              mb_match :: Maybe Subst
mb_match        = Type -> Type -> Maybe Subst
tcUnifyTy Type
inst_ty_kind Type
cls_arg_kind
              enough_args :: Bool
enough_args     = Int
n_args_to_keep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0

        -- Check that the result really is well-kinded
        ; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
          [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"class:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind (Class -> TyCon
classTyCon Class
cls))
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls_tys:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tycon:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc)
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls_arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args_to_keep) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty_kind
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls_arg_kind:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cls_arg_kind ]
        ; Bool -> TcRnMessage -> TcRn ()
checkTc (Bool
enough_args Bool -> Bool -> Bool
&& Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
mb_match)
                  (Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                     TyCon -> Type -> Int -> DeriveInstanceErrReason
DerivErrNotWellKinded TyCon
tc Type
cls_arg_kind Int
n_args_to_keep)

        ; let -- Returns a singleton-element list if using ViaStrategy and an
              -- empty list otherwise. Useful for free-variable calculations.
              deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
              deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys = (DerivStrategy GhcTc -> [Type])
-> Maybe (DerivStrategy GhcTc) -> [Type]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Type]
-> (XViaStrategy GhcTc -> [Type]) -> DerivStrategy GhcTc -> [Type]
forall p (pass :: Pass) r.
(p ~ GhcPass pass) =>
r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
foldDerivStrategy [] (XViaStrategy GhcTc -> [XViaStrategy GhcTc] -> [XViaStrategy GhcTc]
forall a. a -> [a] -> [a]
:[]))

              propagate_subst :: Subst
-> [TyVar]
-> [Type]
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
propagate_subst Subst
kind_subst [TyVar]
tkvs' [Type]
cls_tys' [Type]
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
                = ([TyVar]
final_tkvs, [Type]
final_cls_tys, [Type]
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat)
                where
                  ki_subst_range :: VarSet
ki_subst_range  = Subst -> VarSet
getSubstRangeTyCoFVs Subst
kind_subst
                  -- See Note [Unification of two kind variables in deriving]
                  unmapped_tkvs :: [TyVar]
unmapped_tkvs   = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> Subst -> Bool
`notElemSubst` Subst
kind_subst
                                         Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
                                           [TyVar]
tkvs'
                  (Subst
subst, [TyVar]
_)           = HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar])
Subst -> [TyVar] -> (Subst, [TyVar])
substTyVarBndrs Subst
kind_subst [TyVar]
unmapped_tkvs
                  final_tc_args :: [Type]
final_tc_args        = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
tc_args'
                  final_cls_tys :: [Type]
final_cls_tys        = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
cls_tys'
                  final_mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst))
                                              Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
                  -- See Note [Floating `via` type variables]
                  final_tkvs :: [TyVar]
final_tkvs           = [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped ([Type] -> [TyVar]) -> [Type] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
                                         [Type]
final_cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
final_tc_args
                                           [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat

        ; let tkvs :: [TyVar]
tkvs = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ FV -> [TyVar]
fvVarList (FV -> [TyVar]) -> FV -> [TyVar]
forall a b. (a -> b) -> a -> b
$
                     FV -> FV -> FV
unionFV ([Type] -> FV
tyCoFVsOfTypes [Type]
tc_args_to_keep)
                             ([TyVar] -> FV
FV.mkFVs [TyVar]
deriv_tvs)
              Just Subst
kind_subst = Maybe Subst
mb_match
              ([TyVar]
tkvs', [Type]
cls_tys', [Type]
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
                = Subst
-> [TyVar]
-> [Type]
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
propagate_subst Subst
kind_subst [TyVar]
tkvs [Type]
cls_tys
                                  [Type]
tc_args_to_keep Maybe (DerivStrategy GhcTc)
mb_deriv_strat

          -- See Note [Unify kinds in deriving]
        ; ([TyVar]
final_tkvs, [Type]
final_cls_tys, [Type]
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat) <-
            case Maybe (DerivStrategy GhcTc)
mb_deriv_strat' of
              -- Perform an additional unification with the kind of the `via`
              -- type and the result of the previous kind unification.
              Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
                let via_kind :: Type
via_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind XViaStrategy GhcTc
Type
via_ty
                    inst_ty_kind :: Type
inst_ty_kind
                              = HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args')
                    via_match :: Maybe Subst
via_match = Type -> Type -> Maybe Subst
tcUnifyTy Type
inst_ty_kind Type
via_kind

                Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
via_match)
                        (Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                           Type -> Type -> Type -> DeriveInstanceErrReason
DerivErrDerivingViaWrongKind Type
inst_ty_kind XViaStrategy GhcTc
Type
via_ty Type
via_kind)

                let Just Subst
via_subst = Maybe Subst
via_match
                ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc)))
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
forall a b. (a -> b) -> a -> b
$ Subst
-> [TyVar]
-> [Type]
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
propagate_subst Subst
via_subst [TyVar]
tkvs' [Type]
cls_tys'
                                       [Type]
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'

              Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tkvs', [Type]
cls_tys', [Type]
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')

        ; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 1" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
            [ Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat, [TyVar] -> SDoc
pprTyVars [TyVar]
deriv_tvs, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tc_args
            , [TyVar] -> SDoc
pprTyVars ([Type] -> [TyVar]
tyCoVarsOfTypesList [Type]
tc_args)
            , Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args_to_keep, Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n_args_to_drop
            , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty_kind, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cls_arg_kind, Maybe Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Subst
mb_match
            , [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
final_tc_args, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
final_cls_tys ]

        ; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
            [ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
final_tkvs ]

        ; let final_tc_app :: Type
final_tc_app   = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
final_tc_args
              final_cls_args :: [Type]
final_cls_args = [Type]
final_cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
final_tc_app]
        ; Bool -> TcRnMessage -> TcRn ()
checkTc (VarSet -> [Type] -> Bool
allDistinctTyVars ([TyVar] -> VarSet
mkVarSet [TyVar]
final_tkvs) [Type]
args_to_drop) -- (a, b, c)
                  (Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
final_cls_tys Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                     Type -> DeriveInstanceErrReason
DerivErrNoEtaReduce Type
final_tc_app)
                -- Check that
                --  (a) The args to drop are all type variables; eg reject:
                --              data instance T a Int = .... deriving( Monad )
                --  (b) The args to drop are all *distinct* type variables; eg reject:
                --              class C (a :: * -> * -> *) where ...
                --              data instance T a a = ... deriving( C )
                --  (c) The type class args, or remaining tycon args,
                --      do not mention any of the dropped type variables
                --              newtype T a s = ... deriving( ST s )
                --              newtype instance K a a = ... deriving( Monad )
                --
                -- It is vital that the implementation of allDistinctTyVars
                -- expand any type synonyms.
                -- See Note [Eta-reducing type synonyms]

        ; UserTypeCtxt -> Class -> [Type] -> TcRn ()
checkValidInstHead UserTypeCtxt
DerivClauseCtxt Class
cls [Type]
final_cls_args
                -- Check that we aren't deriving an instance of a magical
                -- type like (~) or Coercible (#14916).

        ; EarlyDerivSpec
spec <- Maybe OverlapMode
-> [TyVar]
-> Class
-> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
forall a. Maybe a
Nothing [TyVar]
final_tkvs Class
cls [Type]
final_cls_args
                            (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
forall a. Maybe a
Nothing) Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
        ; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 3" (EarlyDerivSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr EarlyDerivSpec
spec)
        ; EarlyDerivSpec -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return EarlyDerivSpec
spec }


{- Note [tc_args and tycon arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
You might wonder if we could use (tyConArity tc) at this point, rather
than (length tc_args).  But for data families the two can differ!  The
tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which
in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them
from DataFamInstTyCon:

| DataFamInstTyCon          -- See Note [Data type families]
      (CoAxiom Unbranched)
      TyCon   -- The family TyCon
      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
              -- No shorter in length than the tyConTyVars of the family TyCon
              -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv

Notice that the arg tys might not be the same as the family tycon arity
(= length tyConTyVars).

Note [Unify kinds in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#8534)
    data T a b = MkT a deriving( Functor )
    -- where Functor :: (*->*) -> Constraint

So T :: forall k. * -> k -> *.   We want to get
    instance Functor (T * (a:*)) where ...
Notice the '*' argument to T.

Moreover, as well as instantiating T's kind arguments, we may need to instantiate
C's kind args.  Consider (#8865):
  newtype T a b = MkT (Either a b) deriving( Category )
where
  Category :: forall k. (k -> k -> *) -> Constraint
We need to generate the instance
  instance Category * (Either a) where ...
Notice the '*' argument to Category.

So we need to
 * drop arguments from (T a b) to match the number of
   arrows in the (last argument of the) class;
 * and then *unify* kind of the remaining type against the
   expected kind, to figure out how to instantiate C's and T's
   kind arguments.

In the two examples,
 * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )
         i.e.      (k -> *) ~ (* -> *)   to find k:=*.
         yielding  k:=*

 * we unify   kind-of( Either ) ~ kind-of( Category )
         i.e.      (* -> * -> *)  ~ (k -> k -> k)
         yielding  k:=*

Now we get a kind substitution.  We then need to:

  1. Remove the substituted-out kind variables from the quantified kind vars

  2. Apply the substitution to the kinds of quantified *type* vars
     (and extend the substitution to reflect this change)

  3. Apply that extended substitution to the non-dropped args (types and
     kinds) of the type and class

Forgetting step (2) caused #8893:
  data V a = V [a] deriving Functor
  data P (x::k->*) (a:k) = P (x a) deriving Functor
  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor

When deriving Functor for P, we unify k to *, but we then want
an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
and similarly for C.  Notice the modified kind of x, both at binding
and occurrence sites.

This can lead to some surprising results when *visible* kind binder is
unified (in contrast to the above examples, in which only non-visible kind
binders were considered). Consider this example from #11732:

    data T k (a :: k) = MkT deriving Functor

Since unification yields k:=*, this results in a generated instance of:

    instance Functor (T *) where ...

which looks odd at first glance, since one might expect the instance head
to be of the form Functor (T k). Indeed, one could envision an alternative
generated instance of:

    instance (k ~ *) => Functor (T k) where

But this does not typecheck by design: kind equalities are not allowed to be
bound in types, only terms. But in essence, the two instance declarations are
entirely equivalent, since even though (T k) matches any kind k, the only
possibly value for k is *, since anything else is ill-typed. As a result, we can
just as comfortably use (T *).

Another way of thinking about is: deriving clauses often infer constraints.
For example:

    data S a = S a deriving Eq

infers an (Eq a) constraint in the derived instance. By analogy, when we
are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
The only distinction is that GHC instantiates equality constraints directly
during the deriving process.

Another quirk of this design choice manifests when typeclasses have visible
kind parameters. Consider this code (also from #11732):

    class Cat k (cat :: k -> k -> *) where
      catId   :: cat a a
      catComp :: cat b c -> cat a b -> cat a c

    instance Cat * (->) where
      catId   = id
      catComp = (.)

    newtype Fun a b = Fun (a -> b) deriving (Cat k)

Even though we requested a derived instance of the form (Cat k Fun), the
kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
the user wrote deriving (Cat *)).

What happens with DerivingVia, when you have yet another type? Consider:

  newtype Foo (a :: Type) = MkFoo (Proxy a)
    deriving Functor via Proxy

As before, we unify the kind of Foo (* -> *) with the kind of the argument to
Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
(k -> *), which is more general than what we want. So we must additionally
unify (k -> *) with (* -> *).

Currently, all of this unification is implemented kludgily with the pure
unifier, which is rather tiresome. #14331 lays out a plan for how this
might be made cleaner.

Note [Unification of two kind variables in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As a special case of the Note above, it is possible to derive an instance of
a poly-kinded typeclass for a poly-kinded datatype. For example:

    class Category (cat :: k -> k -> *) where
    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category

This case is surprisingly tricky. To see why, let's write out what instance GHC
will attempt to derive (using -fprint-explicit-kinds syntax):

    instance Category k1 (T k2 c) where ...

GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
the type variable binder for c, since its kind is (k2 -> k2 -> *).

We used to accomplish this by doing the following:

    unmapped_tkvs = filter (`notElemSubst` kind_subst) all_tkvs
    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs

Where all_tkvs contains all kind variables in the class and instance types (in
this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
This is bad, because applying that substitution yields the following instance:

   instance Category k_new (T k1 c) where ...

In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
in an ill-kinded instance (this caused #11837).

To prevent this, we need to filter out any variable from all_tkvs which either

1. Appears in the domain of kind_subst. notElemSubst checks this.
2. Appears in the range of kind_subst. To do this, we compute the free
   variable set of the range of kind_subst with getSubstRangeTyCoFVs, and check
   if a kind variable appears in that set.

Note [Eta-reducing type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One can instantiate a type in a data family instance with a type synonym that
mentions other type variables:

  type Const a b = a
  data family Fam (f :: * -> *) (a :: *)
  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor

It is also possible to define kind synonyms, and they can mention other types in
a datatype declaration. For example,

  type Const a b = a
  newtype T f (a :: Const * f) = T (f a) deriving Functor

When deriving, we need to perform eta-reduction analysis to ensure that none of
the eta-reduced type variables are mentioned elsewhere in the declaration. But
we need to be careful, because if we don't expand through the Const type
synonym, we will mistakenly believe that f is an eta-reduced type variable and
fail to derive Functor, even though the code above is correct (see #11416,
where this was first noticed). For this reason, we expand the type synonyms in
the eta-reduced types before doing any analysis.

Note [Floating `via` type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When generating a derived instance, it will be of the form:

  instance forall ???. C c_args (D d_args) where ...

To fill in ???, GHC computes the free variables of `c_args` and `d_args`.
`DerivingVia` adds an extra wrinkle to this formula, since we must also
include the variables bound by the `via` type when computing the binders
used to fill in ???. This might seem strange, since if a `via` type binds
any type variables, then in almost all scenarios it will appear free in
`c_args` or `d_args`. There are certain corner cases where this does not hold,
however, such as in the following example (adapted from #15831):

  newtype Age = MkAge Int
    deriving Eq via Const Int a

In this example, the `via` type binds the type variable `a`, but `a` appears
nowhere in `Eq Age`. Nevertheless, we include it in the generated instance:

  instance forall a. Eq Age where
    (==) = coerce @(Const Int a -> Const Int a -> Bool)
                  @(Age         -> Age         -> Bool)
                  (==)

The use of `forall a` is certainly required here, since the `a` in
`Const Int a` would not be in scope otherwise. This instance is somewhat
strange in that nothing in the instance head `Eq Age` ever determines what `a`
will be, so any code that uses this instance will invariably instantiate `a`
to be `Any`. We refer to this property of `a` as being a "floating" `via`
type variable. Programs with floating `via` type variables are the only known
class of program in which the `via` type quantifies type variables that aren't
mentioned in the instance head in the generated instance.

Fortunately, the choice to instantiate floating `via` type variables to `Any`
is one that is completely transparent to the user (since the instance will
work as expected regardless of what `a` is instantiated to), so we decide to
permit them. An alternative design would make programs with floating `via`
variables illegal, by requiring that every variable mentioned in the `via` type
is also mentioned in the data header or the derived class. That restriction
would require the user to pick a particular type (the choice does not matter);
for example:

  newtype Age = MkAge Int
    -- deriving Eq via Const Int a  -- Floating 'a'
    deriving Eq via Const Int ()    -- Choose a=()
    deriving Eq via Const Int Any   -- Choose a=Any

No expressiveness would be lost thereby, but stylistically it seems preferable
to allow a type variable to indicate "it doesn't matter".

Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the
work of instantiating `a` to `Any` at every use site of the instance. An
alternative approach would be to generate an instance that directly defaulted
to `Any`:

  instance Eq Age where
    (==) = coerce @(Const Int Any -> Const Int Any -> Bool)
                  @(Age           -> Age           -> Bool)
                  (==)

We do not implement this approach since it would require a nontrivial amount
of implementation effort to substitute `Any` for the floating `via` type
variables, and since the end result isn't distinguishable from the former
instance (at least from the user's perspective), the amount of engineering
required to obtain the latter instance just isn't worth it.
-}

mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
          -> Class -> [Type]
          -> DerivContext
               -- SupplyContext => context supplied (standalone deriving)
               -- InferContext  => context inferred (deriving on data decl, or
               --                  standalone deriving decl with a wildcard)
          -> Maybe (DerivStrategy GhcTc)
          -> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
--      forall tvs. theta => cls (tys ++ [ty])
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded

mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class
-> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
overlap_mode [TyVar]
tvs Class
cls [Type]
cls_args DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
deriv_strat = do
  Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
  Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_boot (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason -> TcRn ()
bale_out DeriveInstanceErrReason
DerivErrBootFileFound

  let pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_args
  SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (Type -> SkolemInfoAnon
DerivSkol Type
pred)
  ([TyVar]
tvs', [Type]
cls_args', Maybe (DerivStrategy GhcTc)
deriv_strat') <-
    SkolemInfo
-> DerivContext
-> TcM ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context SkolemInfo
skol_info DerivContext
deriv_ctxt
  let deriv_env :: DerivEnv
deriv_env = DerivEnv
                    { denv_overlap_mode :: Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
                    , denv_tvs :: [TyVar]
denv_tvs          = [TyVar]
tvs'
                    , denv_cls :: Class
denv_cls          = Class
cls
                    , denv_inst_tys :: [Type]
denv_inst_tys     = [Type]
cls_args'
                    , denv_ctxt :: DerivContext
denv_ctxt         = DerivContext
deriv_ctxt
                    , denv_skol_info :: SkolemInfo
denv_skol_info    = SkolemInfo
skol_info
                    , denv_strat :: Maybe (DerivStrategy GhcTc)
denv_strat        = Maybe (DerivStrategy GhcTc)
deriv_strat' }
  ReaderT DerivEnv TcRn EarlyDerivSpec
-> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn DerivEnv
deriv_env
  where
    skolemise_when_inferring_context ::
         SkolemInfo -> DerivContext
      -> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))
    skolemise_when_inferring_context :: SkolemInfo
-> DerivContext
-> TcM ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context SkolemInfo
skol_info DerivContext
deriv_ctxt =
      case DerivContext
deriv_ctxt of
        -- In order to infer an instance context, we must later make use of
        -- the constraint solving machinery, which expects TcTyVars rather
        -- than TyVars. We skolemise the type variables with non-overlappable
        -- (vanilla) skolems.
        -- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.
        InferContext{} -> do
          (Subst
skol_subst, [TyVar]
tvs') <- SkolemInfo -> [TyVar] -> TcM (Subst, [TyVar])
tcInstSkolTyVars SkolemInfo
skol_info [TyVar]
tvs
          let cls_args' :: [Type]
cls_args'    = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
skol_subst [Type]
cls_args
              deriv_strat' :: Maybe (DerivStrategy GhcTc)
deriv_strat' = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
skol_subst))
                                  Maybe (DerivStrategy GhcTc)
deriv_strat
          ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
-> TcM ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs', [Type]
cls_args', Maybe (DerivStrategy GhcTc)
deriv_strat')
        -- If the instance context is supplied, we don't need to skolemise
        -- at all.
        SupplyContext{} -> ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
-> TcM ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, [Type]
cls_args, Maybe (DerivStrategy GhcTc)
deriv_strat)

    bale_out :: DeriveInstanceErrReason -> TcRn ()
bale_out =
      TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ())
-> (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason
-> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
cls_args Maybe (DerivStrategy GhcTc)
deriv_strat UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving

    mk_eqn :: DerivM EarlyDerivSpec
    mk_eqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn = do
      DerivEnv { denv_inst_tys :: DerivEnv -> [Type]
denv_inst_tys = [Type]
cls_args
               , denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat    = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      case Maybe (DerivStrategy GhcTc)
mb_strat of
        Just (StockStrategy XStockStrategy GhcTc
_) -> do
          ([Type]
cls_tys, Type
inst_ty) <- [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
cls_args
          DerivInstTys
dit                <- [Type] -> Type -> DerivM DerivInstTys
expectAlgTyConApp [Type]
cls_tys Type
inst_ty
          DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivInstTys
dit

        Just (AnyclassStrategy XAnyClassStrategy GhcTc
_) -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass

        Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
          ([Type]
cls_tys, Type
inst_ty) <- [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
cls_args
          [Type] -> Type -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via [Type]
cls_tys Type
inst_ty XViaStrategy GhcTc
Type
via_ty

        Just (NewtypeStrategy XNewtypeStrategy GhcTc
_) -> do
          ([Type]
cls_tys, Type
inst_ty) <- [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
cls_args
          DerivInstTys
dit                <- [Type] -> Type -> DerivM DerivInstTys
expectAlgTyConApp [Type]
cls_tys Type
inst_ty
          Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isNewTyCon (DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit)) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
            UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrGNDUsedOnData
          Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
True DerivInstTys
dit

        Maybe (DerivStrategy GhcTc)
Nothing -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy

-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.
-- If so, return @(init inst_tys, last inst_tys)@.
-- Otherwise, throw an error message.
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
-- property is important.
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
inst_tys =
  DerivM ([Type], Type)
-> (([Type], Type) -> DerivM ([Type], Type))
-> Maybe ([Type], Type)
-> DerivM ([Type], Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM ([Type], Type)
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrNullaryClasses) ([Type], Type) -> DerivM ([Type], Type)
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([Type], Type) -> DerivM ([Type], Type))
-> Maybe ([Type], Type) -> DerivM ([Type], Type)
forall a b. (a -> b) -> a -> b
$
  [Type] -> Maybe ([Type], Type)
forall a. [a] -> Maybe ([a], a)
snocView [Type]
inst_tys

-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application
-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting
-- of @cls_tys@ and the constituent pars of @inst_ty@.
-- Otherwise, throw an error message.
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
-- property is important.
expectAlgTyConApp :: [Type] -- All but the last argument to the class in a
                            -- derived instance
                  -> Type   -- The last argument to the class in a
                            -- derived instance
                  -> DerivM DerivInstTys
expectAlgTyConApp :: [Type] -> Type -> DerivM DerivInstTys
expectAlgTyConApp [Type]
cls_tys Type
inst_ty = do
  FamInstEnvs
fam_envs <- TcRn FamInstEnvs -> ReaderT DerivEnv TcRn FamInstEnvs
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn FamInstEnvs
tcGetFamInstEnvs
  case FamInstEnvs -> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [Type]
cls_tys Type
inst_ty of
    Maybe DerivInstTys
Nothing -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM DerivInstTys
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrLastArgMustBeApp
    Just DerivInstTys
dit -> do DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
                   DerivInstTys -> DerivM DerivInstTys
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivInstTys
dit

-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation
-- type constructor for a data family instance, and if not,
-- throws an error message.
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
-- property is important.
expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
expectNonDataFamTyCon :: DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc      = TyCon
tc
                                    , dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
                                    , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc  = TyCon
rep_tc }) =
  -- If it's still a data family, the lookup failed; i.e no instance exists
  Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isDataFamilyTyCon TyCon
rep_tc) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
    UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ())
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
      TyCon -> [Type] -> DeriveInstanceErrReason
DerivErrNoFamilyInstance TyCon
tc [Type]
tc_args

mk_deriv_inst_tys_maybe :: FamInstEnvs
                        -> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe :: FamInstEnvs -> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [Type]
cls_tys Type
inst_ty =
  ((TyCon, [Type]) -> DerivInstTys)
-> Maybe (TyCon, [Type]) -> Maybe DerivInstTys
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon, [Type]) -> DerivInstTys
lookup (Maybe (TyCon, [Type]) -> Maybe DerivInstTys)
-> Maybe (TyCon, [Type]) -> Maybe DerivInstTys
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
inst_ty
  where
    lookup :: (TyCon, [Type]) -> DerivInstTys
    lookup :: (TyCon, [Type]) -> DerivInstTys
lookup (TyCon
tc, [Type]
tc_args) =
      -- Find the instance of a data family
      -- Note [Looking up family instances for deriving]
      let (TyCon
rep_tc, [Type]
rep_tc_args, Coercion
_co) = FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [Type]
tc_args
          dc_inst_arg_env :: DataConEnv [Type]
dc_inst_arg_env = TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args
      in DerivInstTys { dit_cls_tys :: [Type]
dit_cls_tys         = [Type]
cls_tys
                      , dit_tc :: TyCon
dit_tc              = TyCon
tc
                      , dit_tc_args :: [Type]
dit_tc_args         = [Type]
tc_args
                      , dit_rep_tc :: TyCon
dit_rep_tc          = TyCon
rep_tc
                      , dit_rep_tc_args :: [Type]
dit_rep_tc_args     = [Type]
rep_tc_args
                      , dit_dc_inst_arg_env :: DataConEnv [Type]
dit_dc_inst_arg_env = DataConEnv [Type]
dc_inst_arg_env }

{-
Note [Looking up family instances for deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcLookupFamInstExact is an auxiliary lookup wrapper which requires
that looked-up family instances exist.  If called with a vanilla
tycon, the old type application is simply returned.

If we have
  data instance F () = ... deriving Eq
  data instance F () = ... deriving Eq
then tcLookupFamInstExact will be confused by the two matches;
but that can't happen because tcInstDecls1 doesn't call tcDeriving
if there are any overlaps.

There are two other things that might go wrong with the lookup.
First, we might see a standalone deriving clause
   deriving Eq (F ())
when there is no data instance F () in scope.

Note that it's OK to have
  data instance F [a] = ...
  deriving Eq (F [(a,b)])
where the match is not exact; the same holds for ordinary data types
with standalone deriving declarations.

Note [Deriving, type families, and partial applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When there are no type families, it's quite easy:

    newtype S a = MkS [a]
    -- :CoS :: S  ~ []  -- Eta-reduced

    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S

When type families are involved it's trickier:

    data family T a b
    newtype instance T Int a = MkT [a] deriving( Eq, Monad )
    -- :RT is the representation type for (T Int a)
    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!

    instance Eq [a] => Eq (T Int a)     -- easy by coercion
       -- d1 :: Eq [a]
       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))

    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
       -- d1 :: Monad []
       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))

Note the need for the eta-reduced rule axioms.  After all, we can
write it out
    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
      return x = MkT [x]
      ... etc ...

See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom

%************************************************************************
%*                                                                      *
                Deriving data types
*                                                                      *
************************************************************************
-}

-- Once the DerivSpecMechanism is known, we can finally produce an
-- EarlyDerivSpec from it.
mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
mk_eqn_from_mechanism :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
mechanism
  = do 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
deriv_ctxt
                , denv_skol_info :: DerivEnv -> SkolemInfo
denv_skol_info    = SkolemInfo
skol_info } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       UserTypeCtxt
user_ctxt <- DerivM UserTypeCtxt
askDerivUserTypeCtxt
       DerivSpecMechanism -> ReaderT DerivEnv TcRn ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism
       SrcSpan
loc       <- TcRn SrcSpan -> ReaderT DerivEnv TcRn SrcSpan
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn SrcSpan
getSrcSpanM
       Name
dfun_name <- IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name)
-> IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName Class
cls [Type]
inst_tys SrcSpan
loc
       case DerivContext
deriv_ctxt of
        InferContext Maybe SrcSpan
wildcard ->
          do { (ThetaSpec
inferred_constraints, [TyVar]
tvs', [Type]
inst_tys', DerivSpecMechanism
mechanism')
                 <- DerivSpecMechanism
-> DerivM (ThetaSpec, [TyVar], [Type], DerivSpecMechanism)
inferConstraints DerivSpecMechanism
mechanism
             ; EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. a -> ReaderT DerivEnv TcRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec ThetaSpec -> EarlyDerivSpec
InferTheta (DerivSpec ThetaSpec -> EarlyDerivSpec)
-> DerivSpec ThetaSpec -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS
                   { ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
                   , ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs'
                   , ds_cls :: Class
ds_cls = Class
cls, ds_tys :: [Type]
ds_tys = [Type]
inst_tys'
                   , ds_theta :: ThetaSpec
ds_theta = ThetaSpec
inferred_constraints
                   , ds_skol_info :: SkolemInfo
ds_skol_info = SkolemInfo
skol_info
                   , ds_user_ctxt :: UserTypeCtxt
ds_user_ctxt = UserTypeCtxt
user_ctxt
                   , ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
                   , ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard
                   , ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism' } }

        SupplyContext [Type]
theta ->
            EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. a -> ReaderT DerivEnv TcRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec [Type] -> EarlyDerivSpec
GivenTheta (DerivSpec [Type] -> EarlyDerivSpec)
-> DerivSpec [Type] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS
                   { ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
                   , ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs
                   , ds_cls :: Class
ds_cls = Class
cls, ds_tys :: [Type]
ds_tys = [Type]
inst_tys
                   , ds_theta :: [Type]
ds_theta = [Type]
theta
                   , ds_skol_info :: SkolemInfo
ds_skol_info = SkolemInfo
skol_info
                   , ds_user_ctxt :: UserTypeCtxt
ds_user_ctxt = UserTypeCtxt
user_ctxt
                   , ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
                   , ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
forall a. Maybe a
Nothing
                   , ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism }

mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class
             -> DerivM EarlyDerivSpec
mk_eqn_stock :: DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivInstTys
dit
  = do DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let isDeriveAnyClassEnabled :: DeriveAnyClassEnabled
isDeriveAnyClassEnabled =
             Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
       DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions DerivInstTys
dit DerivM OriginativeDerivStatus
-> (OriginativeDerivStatus -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b.
ReaderT DerivEnv TcRn a
-> (a -> ReaderT DerivEnv TcRn b) -> ReaderT DerivEnv TcRn b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
         CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 }
         StockClassError DeriveInstanceErrReason
why    -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
why
         OriginativeDerivStatus
CanDeriveAnyClass      -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
                                     (DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled)
         -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass
         -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's
         -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it.
         OriginativeDerivStatus
NonDerivableClass      -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
                                     (DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
YesDeriveAnyClassEnabled)

mk_eqn_anyclass :: DerivM EarlyDerivSpec
mk_eqn_anyclass :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
  = do DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let isDeriveAnyClassEnabled :: DeriveAnyClassEnabled
isDeriveAnyClassEnabled =
             Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
       case Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags of
         Bool
True  -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
         Bool
False -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
                                        (DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled)

mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class
               -> Type         -- The newtype's representation type
               -> DerivM EarlyDerivSpec
mk_eqn_newtype :: DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_ty =
  DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 }

mk_eqn_via :: [Type] -- All arguments to the class besides the last
           -> Type   -- The last argument to the class
           -> Type   -- The @via@ type
           -> DerivM EarlyDerivSpec
mk_eqn_via :: [Type] -> Type -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via [Type]
cls_tys Type
inst_ty Type
via_ty =
  DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 }

-- Derive an instance without a user-requested deriving strategy. This uses
-- heuristics to determine which deriving strategy to use.
-- See Note [Deriving strategies].
mk_eqn_no_strategy :: DerivM EarlyDerivSpec
mk_eqn_no_strategy :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy = do
  DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls      = Class
cls
           , denv_inst_tys :: DerivEnv -> [Type]
denv_inst_tys = [Type]
cls_args } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  FamInstEnvs
fam_envs <- TcRn FamInstEnvs -> ReaderT DerivEnv TcRn FamInstEnvs
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn FamInstEnvs
tcGetFamInstEnvs

  -- First, check if the last argument is an application of a type constructor.
  -- If not, fall back to DeriveAnyClass.
  if |  Just ([Type]
cls_tys, Type
inst_ty) <- [Type] -> Maybe ([Type], Type)
forall a. [a] -> Maybe ([a], a)
snocView [Type]
cls_args
     ,  Just DerivInstTys
dit <- FamInstEnvs -> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [Type]
cls_tys Type
inst_ty
     -> if |  TyCon -> Bool
isNewTyCon (DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit)
              -- We have a dedicated code path for newtypes (see the
              -- documentation for mkNewTypeEqn as to why this is the case)
           -> Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
False DerivInstTys
dit

           |  Bool
otherwise
           -> do -- Otherwise, our only other options are stock or anyclass.
                 -- If it is stock, we must confirm that the last argument's
                 -- type constructor is algebraic.
                 -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils
                 Maybe StockGenFns
-> (StockGenFns -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Class -> Maybe StockGenFns
hasStockDeriving Class
cls) ((StockGenFns -> ReaderT DerivEnv TcRn ())
 -> ReaderT DerivEnv TcRn ())
-> (StockGenFns -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ \StockGenFns
_ ->
                   DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
                 Class -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative Class
cls DerivInstTys
dit

     |  Bool
otherwise
     -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
  where
    -- Use heuristics (checkOriginativeSideConditions) to determine whether
    -- stock or anyclass deriving should be used.
    mk_eqn_originative :: Class -> DerivInstTys -> DerivM EarlyDerivSpec
    mk_eqn_originative :: Class -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative Class
cls dit :: DerivInstTys
dit@(DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc     = TyCon
tc
                                             , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
      DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let isDeriveAnyClassEnabled :: DeriveAnyClassEnabled
isDeriveAnyClassEnabled
            | Class -> Bool
canSafelyDeriveAnyClass Class
cls
            = Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
            | Bool
otherwise
            -- Pretend that the extension is enabled so that we won't suggest
            -- enabling it.
            = DeriveAnyClassEnabled
YesDeriveAnyClassEnabled

      -- See Note [Deriving instances for classes themselves]
      let dac_error :: DeriveInstanceErrReason
dac_error
            | TyCon -> Bool
isClassTyCon TyCon
rep_tc
            = TyCon -> DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrOnlyAnyClassDeriveable TyCon
tc DeriveAnyClassEnabled
isDeriveAnyClassEnabled
            | Bool
otherwise
            = DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled

      DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions DerivInstTys
dit DerivM OriginativeDerivStatus
-> (OriginativeDerivStatus -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b.
ReaderT DerivEnv TcRn a
-> (a -> ReaderT DerivEnv TcRn b) -> ReaderT DerivEnv TcRn b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        OriginativeDerivStatus
NonDerivableClass      -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
dac_error
        StockClassError DeriveInstanceErrReason
why    -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
why
        CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 }
        OriginativeDerivStatus
CanDeriveAnyClass      -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass

    canSafelyDeriveAnyClass :: Class -> Bool
canSafelyDeriveAnyClass Class
cls =
      -- If the set of minimal required definitions is nonempty,
      -- `DeriveAnyClass` will generate an instance with undefined methods or
      -- associated types, so don't suggest enabling it.
      Maybe (BooleanFormula Name) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (BooleanFormula Name) -> Bool)
-> Maybe (BooleanFormula Name) -> Bool
forall a b. (a -> b) -> a -> b
$ (Name -> Bool)
-> BooleanFormula Name -> Maybe (BooleanFormula Name)
forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied (Bool -> Name -> Bool
forall a b. a -> b -> a
const Bool
False) (Class -> BooleanFormula Name
classMinimalDef Class
cls)

{-
************************************************************************
*                                                                      *
            Deriving instances for newtypes
*                                                                      *
************************************************************************
-}

-- Derive an instance for a newtype. We put this logic into its own function
-- because
--
-- (a) When no explicit deriving strategy is requested, we have special
--     heuristics for newtypes to determine which deriving strategy should
--     actually be used. See Note [Deriving strategies].
-- (b) We make an effort to give error messages specifically tailored to
--     newtypes.
mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@
                     -- deriving strategy?
             -> DerivInstTys -> DerivM EarlyDerivSpec
mkNewTypeEqn :: Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
newtype_strat dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys     = [Type]
cls_tys
                                             , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc      = TyCon
rep_tycon
                                             , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args })
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
  = do DerivEnv{denv_cls :: DerivEnv -> Class
denv_cls = Class
cls} <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

       let newtype_deriving :: Bool
newtype_deriving  = Extension -> DynFlags -> Bool
xopt Extension
LangExt.GeneralizedNewtypeDeriving DynFlags
dflags
           deriveAnyClass :: Bool
deriveAnyClass    = Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass             DynFlags
dflags

           bale_out :: DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out = UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith (Bool -> UsingGeneralizedNewtypeDeriving
usingGeneralizedNewtypeDeriving Bool
newtype_deriving)

           -- Here is the plan for newtype derivings.  We see
           --        newtype T a1...an = MkT (t ak+1...an)
           --          deriving (.., C s1 .. sm, ...)
           -- where t is a type,
           --       ak+1...an is a suffix of a1..an, and are all tyvars
           --       ak+1...an do not occur free in t, nor in the s1..sm
           --       (C s1 ... sm) is a  *partial applications* of class C
           --                      with the last parameter missing
           --       (T a1 .. ak) matches the kind of C's last argument
           --              (and hence so does t)
           -- The latter kind-check has been done by deriveTyData already,
           -- and tc_args are already trimmed
           --
           -- We generate the instance
           --       instance forall ({a1..ak} u fvs(s1..sm)).
           --                C s1 .. sm t => C s1 .. sm (T a1...ak)
           -- where T a1...ap is the partial application of
           --       the LHS of the correct kind and p >= k
           --
           --      NB: the variables below are:
           --              tc_tvs = [a1, ..., an]
           --              tyvars_to_keep = [a1, ..., ak]
           --              rep_ty = t ak .. an
           --              deriv_tvs = fvs(s1..sm) \ tc_tvs
           --              tys = [s1, ..., sm]
           --              rep_fn' = t
           --
           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
           -- We generate the instance
           --      instance Monad (ST s) => Monad (T s) where

           nt_eta_arity :: Int
nt_eta_arity = TyCon -> Int
newTyConEtadArity TyCon
rep_tycon
                   -- For newtype T a b = MkT (S a a b), the TyCon
                   -- machinery already eta-reduces the representation type, so
                   -- we know that
                   --      T a ~ S a a
                   -- That's convenient here, because we may have to apply
                   -- it to fewer than its original complement of arguments

           -- Note [Newtype representation]
           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           -- Need newTyConRhs (*not* a recursive representation finder)
           -- to get the representation type. For example
           --      newtype B = MkB Int
           --      newtype A = MkA B deriving( Num )
           -- We want the Num instance of B, *not* the Num instance of Int,
           -- when making the Num instance of A!
           rep_inst_ty :: Type
rep_inst_ty = TyCon -> [Type] -> Type
newTyConInstRhs TyCon
rep_tycon [Type]
rep_tc_args

           -------------------------------------------------------------------
           --  Figuring out whether we can only do this newtype-deriving thing

           -- See Note [Determining whether newtype-deriving is appropriate]
           might_be_newtype_derivable :: Bool
might_be_newtype_derivable
              =  Bool -> Bool
not (Class -> Bool
non_coercible_class Class
cls)
              Bool -> Bool -> Bool
&& Bool
eta_ok
--            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]

           -- Check that eta reduction is OK
           eta_ok :: Bool
eta_ok = [Type]
rep_tc_args [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
nt_eta_arity
             -- The newtype can be eta-reduced to match the number
             --     of type argument actually supplied
             --        newtype T a b = MkT (S [a] b) deriving( Monad )
             --     Here the 'b' must be the same in the rep type (S [a] b)
             --     And the [a] must not mention 'b'.  That's all handled
             --     by nt_eta_rity.

       Bool -> ReaderT DerivEnv TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([Type]
cls_tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (Class -> Int
classArity Class
cls Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
       if Bool
newtype_strat
       then
           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
           -- we don't need to perform all of the checks we normally would,
           -- such as if the class being derived is known to produce ill-roled
           -- coercions (e.g., Traversable), since we can just derive the
           -- instance and let it error if need be.
           -- See Note [Determining whether newtype-deriving is appropriate]
           if Bool
eta_ok Bool -> Bool -> Bool
&& Bool
newtype_deriving
             then DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_inst_ty
             else DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (Bool -> DeriveInstanceErrReason
DerivErrCannotEtaReduceEnough Bool
eta_ok)
       else
         if Bool
might_be_newtype_derivable
             Bool -> Bool -> Bool
&& ((Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriveAnyClass)
                  Bool -> Bool -> Bool
|| Class -> Bool
std_class_via_coercible Class
cls)
         then DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_inst_ty
         else DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions DerivInstTys
dit DerivM OriginativeDerivStatus
-> (OriginativeDerivStatus -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b.
ReaderT DerivEnv TcRn a
-> (a -> ReaderT DerivEnv TcRn b) -> ReaderT DerivEnv TcRn b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               StockClassError DeriveInstanceErrReason
why
                 -- There's a particular corner case where
                 --
                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
                 --    both enabled at the same time
                 -- 2. We're deriving a particular stock derivable class
                 --    (such as Functor)
                 --
                 -- and the previous cases won't catch it. This fixes the bug
                 -- reported in #10598.
                 | Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool
newtype_deriving
                -> DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_inst_ty
                 -- Otherwise, throw an error for a stock class
                 | Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
newtype_deriving
                -> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out DeriveInstanceErrReason
why
                 | Bool
otherwise
                -> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out DeriveInstanceErrReason
why

               -- Must use newtype deriving or DeriveAnyClass
               OriginativeDerivStatus
NonDerivableClass
                 -- Too hard, even with newtype deriving
                 | Bool
newtype_deriving           -> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (Bool -> DeriveInstanceErrReason
DerivErrCannotEtaReduceEnough Bool
eta_ok)
                 -- Try newtype deriving!
                 -- Here we suggest GeneralizedNewtypeDeriving even in cases
                 -- where it may not be applicable. See #9600.
                 | Bool
otherwise                  -> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out DeriveInstanceErrReason
DerivErrNewtypeNonDeriveableClass

               -- DeriveAnyClass
               OriginativeDerivStatus
CanDeriveAnyClass -> do
                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
                 -- enabled, we take the diplomatic approach of defaulting to
                 -- DeriveAnyClass, but emitting a warning about the choice.
                 -- See Note [Deriving strategies]
                 Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool
deriveAnyClass) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
                   TcRn () -> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnosticTc
                        (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Class -> TcRnMessage
TcRnDerivingDefaults Class
cls
                 DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
               -- CanDeriveStock
               CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 }

{-
Note [Recursive newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~
Newtype deriving works fine, even if the newtype is recursive.
e.g.    newtype S1 = S1 [T1 ()]
        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
Remember, too, that type families are currently (conservatively) given
a recursive flag, so this also allows newtype deriving to work
for type families.

We used to exclude recursive types, because we had a rather simple
minded way of generating the instance decl:
   newtype A = MkA [A]
   instance Eq [A] => Eq A      -- Makes typechecker loop!
But now we require a simple context, so it's ok.

Note [Determining whether newtype-deriving is appropriate]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
  newtype NT = MkNT Foo
    deriving C
we have to decide how to perform the deriving. Do we do newtype deriving,
or do we do normal deriving? In general, we prefer to do newtype deriving
wherever possible. So, we try newtype deriving unless there's a glaring
reason not to.

"Glaring reasons not to" include trying to derive a class for which a
coercion-based instance doesn't make sense. These classes are listed in
the definition of non_coercible_class. They include Show (since it must
show the name of the datatype) and Traversable (since a coercion-based
Traversable instance is ill-roled).

However, non_coercible_class is ignored if the user explicitly requests
to derive an instance with GeneralizedNewtypeDeriving using the newtype
deriving strategy. In such a scenario, GHC will unquestioningly try to
derive the instance via coercions (even if the final generated code is
ill-roled!). See Note [Deriving strategies].

Note that newtype deriving might fail, even after we commit to it. This
is because the derived instance uses `coerce`, which must satisfy its
`Coercible` constraint. This is different than other deriving scenarios,
where we're sure that the resulting instance will type-check.

Note [GND and associated type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for
classes with associated type families. A general recipe is:

    class C x y z where
      type T y z x
      op :: x -> [y] -> z

    newtype N a = MkN <rep-type> deriving( C )

    =====>

    instance C x y <rep-type> => C x y (N a) where
      type T y (N a) x = T y <rep-type> x
      op = coerce (op :: x -> [y] -> <rep-type>)

However, we must watch out for three things:

(a) The class must not contain any data families. If it did, we'd have to
    generate a fresh data constructor name for the derived data family
    instance, and it's not clear how to do this.

(b) Each associated type family's type variables must mention the last type
    variable of the class. As an example, you wouldn't be able to use GND to
    derive an instance of this class:

      class C a b where
        type T a

    But you would be able to derive an instance of this class:

      class C a b where
        type T b

    The difference is that in the latter T mentions the last parameter of C
    (i.e., it mentions b), but the former T does not. If you tried, e.g.,

      newtype Foo x = Foo x deriving (C a)

    with the former definition of C, you'd end up with something like this:

      instance C a (Foo x) where
        type T a = T ???

    This T family instance doesn't mention the newtype (or its representation
    type) at all, so we disallow such constructions with GND.

(c) UndecidableInstances might need to be enabled. Here's a case where it is
    most definitely necessary:

      class C a where
        type T a
      newtype Loop = Loop MkLoop deriving C

      =====>

      instance C Loop where
        type T Loop = T Loop

    Obviously, T Loop would send the typechecker into a loop. Unfortunately,
    you might even need UndecidableInstances even in cases where the
    typechecker would be guaranteed to terminate. For example:

      instance C Int where
        type C Int = Int
      newtype MyInt = MyInt Int deriving C

      =====>

      instance C MyInt where
        type T MyInt = T Int

    GHC's termination checker isn't sophisticated enough to conclude that the
    definition of T MyInt terminates, so UndecidableInstances is required.

(d) For the time being, we do not allow the last type variable of the class to
    appear in a /kind/ of an associated type family definition. For instance:

    class C a where
      type T1 a        -- OK
      type T2 (x :: a) -- Illegal: a appears in the kind of x
      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)

    The reason we disallow this is because our current approach to deriving
    associated type family instances—i.e., by unwrapping the newtype's type
    constructor as shown above—is ill-equipped to handle the scenario when
    the last type variable appears as an implicit argument. In the worst case,
    allowing the last variable to appear in a kind can result in improper Core
    being generated (see #14728).

    There is hope for this feature being added some day, as one could
    conceivably take a newtype axiom (which witnesses a coercion between a
    newtype and its representation type) at lift that through each associated
    type at the Core level. See #14728, comment:3 for a sketch of how this
    might work. Until then, we disallow this featurette wholesale.

The same criteria apply to DerivingVia.

************************************************************************
*                                                                      *
Bindings for the various classes
*                                                                      *
************************************************************************

After all the trouble to figure out the required context for the
derived instance declarations, all that's left is to chug along to
produce them.  They will then be shoved into @tcInstDecls2@, which
will do all its usual business.

There are lots of possibilities for code to generate.  Here are
various general remarks.

PRINCIPLES:
\begin{itemize}
\item
We want derived instances of @Eq@ and @Ord@ (both v common) to be
``you-couldn't-do-better-by-hand'' efficient.

\item
Deriving @Show@---also pretty common--- should also be reasonable good code.

\item
Deriving for the other classes isn't that common or that big a deal.
\end{itemize}

PRAGMATICS:

\begin{itemize}
\item
Deriving @Ord@ is done mostly with the 1.3 @compare@ method.

\item
Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.

\item
We {\em normally} generate code only for the non-defaulted methods;
there are some exceptions for @Eq@ and (especially) @Ord@...

\item
Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
constructor's numeric (@Int#@) tag.  These are generated by
@gen_tag_n_con_binds@, and the heuristic for deciding if one of
these is around is given by @hasCon2TagFun@.

The examples under the different sections below will make this
clearer.

\item
Much less often (really just for deriving @Ix@), we use a
@_tag2con_<tycon>@ function.  See the examples.

\item
We use the renamer!!!  Reason: we're supposed to be
producing @LHsBinds Name@ for the methods, but that means
producing correctly-uniquified code on the fly.  This is entirely
possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
So, instead, we produce @MonoBinds RdrName@ then heave 'em through
the renamer.  What a great hack!
\end{itemize}
-}

-- | Generate the 'InstInfo' for the required instance,
-- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in
-- "GHC.Tc.Deriv.Generate") and any additional free variables
-- that should be marked (see @Note [Deriving and unused record selectors]@
-- in "GHC.Tc.Deriv.Utils").
genInstBinds :: DerivSpec ThetaType
             -> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds :: DerivSpec [Type]
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds spec :: DerivSpec [Type]
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
                      , ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
inst_tys, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = [Type]
theta, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas
                      , ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_standalone_wildcard :: forall theta. DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard })
  = DerivSpec [Type]
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt DerivSpec [Type]
spec (IOEnv
   (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall a b. (a -> b) -> a -> b
$
    do (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
meth_binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
meth_sigs, Bag AuxBindSpec
aux_specs, [Name]
unusedNames) <- TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
IOEnv
  (Env TcGblEnv TcLclEnv)
  (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
   [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_inst_binds
       ClsInst
inst_spec <- DerivSpec [Type] -> TcM ClsInst
newDerivClsInst DerivSpec [Type]
spec
       Class
-> ClsInst
-> [Type]
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
inst_spec [Type]
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
       String -> SDoc -> TcRn ()
traceTc String
"newder" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
inst_spec)
       let inst_info :: InstInfo GhcPs
inst_info =
             InstInfo
               { iSpec :: ClsInst
iSpec   = ClsInst
inst_spec
               , iBinds :: InstBindings GhcPs
iBinds  = InstBindings
                             { ib_binds :: LHsBindsLR GhcPs GhcPs
ib_binds = LHsBindsLR GhcPs GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
meth_binds
                             , ib_tyvars :: [Name]
ib_tyvars = (TyVar -> Name) -> [TyVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Name
Var.varName [TyVar]
tyvars
                             , ib_pragmas :: [LSig GhcPs]
ib_pragmas = [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
meth_sigs
                             , ib_extensions :: [Extension]
ib_extensions = [Extension]
extensions
                             , ib_derived :: Bool
ib_derived = Bool
True } }
       (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs
inst_info, Bag AuxBindSpec
aux_specs, [Name]
unusedNames)
  where
    extensions :: [LangExt.Extension]
    extensions :: [Extension]
extensions
      | DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism Bool -> Bool -> Bool
|| DerivSpecMechanism -> Bool
isDerivSpecVia DerivSpecMechanism
mechanism
      = [
          -- Both these flags are needed for higher-rank uses of coerce...
          Extension
LangExt.ImpredicativeTypes, Extension
LangExt.RankNTypes
          -- ...and this flag is needed to support the instance signatures
          -- that bring type variables into scope.
          -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate
        , Extension
LangExt.InstanceSigs
          -- Skip unboxed tuples checking for derived instances when imported
          -- in a different module, see #20524
        , Extension
LangExt.UnboxedTuples
        ]
      | Bool
otherwise
      = []

    gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
    gen_inst_binds :: TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_inst_binds
      = case DerivSpecMechanism
mechanism of
          -- See Note [Bindings for Generalised Newtype Deriving]
          DerivSpecNewtype { dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rhs_ty}
            -> Type
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
rhs_ty

          -- Try a stock deriver
          DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit
                         , dsm_stock_gen_fns :: DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns =
                             StockGenFns { stock_gen_binds :: StockGenFns
-> SrcSpan
-> DerivInstTys
-> TcM
     (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
stock_gen_binds = SrcSpan
-> DerivInstTys
-> TcM
     (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_fn } }
            -> SrcSpan
-> DerivInstTys
-> TcM
     (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_fn SrcSpan
loc DerivInstTys
dit

          -- Try DeriveAnyClass
          DerivSpecMechanism
DerivSpecAnyClass
            -> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. Bag a
emptyBag, [], Bag AuxBindSpec
forall a. Bag a
emptyBag, [])
               -- No method bindings, signatures, auxiliary bindings or free
               -- variable names are needed. The only interesting work happens when
               -- defaulting associated type family instances (see the
               -- DeriveSpecAnyClass case in genFamInsts below).

          -- Try DerivingVia
          DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty}
            -> Type
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
via_ty

    gen_newtype_or_via :: Type
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
ty = do
      let (LHsBindsLR GhcPs GhcPs
binds, [LSig GhcPs]
sigs) = SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])
gen_Newtype_binds SrcSpan
loc Class
clas [TyVar]
tyvars [Type]
inst_tys Type
ty
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      [GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBindsLR GhcPs GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, Bag AuxBindSpec
forall a. Bag a
emptyBag, [])

-- | Generate the associated type family instances for a derived instance.
genFamInsts :: DerivSpec theta -> TcM [FamInst]
genFamInsts :: forall theta.
DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts spec :: DerivSpec theta
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
                     , ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
inst_tys, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc })
  = DerivSpec theta
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt DerivSpec theta
spec (IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
 -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall a b. (a -> b) -> a -> b
$
    case DerivSpecMechanism
mechanism of
      -- See Note [GND and associated type families]
      DerivSpecNewtype { dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rhs_ty}
        -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_newtype_or_via Type
rhs_ty

      -- Try a stock deriver
      DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit
                     , dsm_stock_gen_fns :: DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns =
                         StockGenFns { stock_gen_fam_insts :: StockGenFns
-> SrcSpan
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
stock_gen_fam_insts = SrcSpan -> DerivInstTys -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_fn } }
        -> SrcSpan -> DerivInstTys -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_fn SrcSpan
loc DerivInstTys
dit

      -- See Note [DeriveAnyClass and default family instances]
      DerivSpecMechanism
DerivSpecAnyClass -> do
        let mini_env :: VarEnv Type
mini_env   = [(TyVar, Type)] -> VarEnv Type
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (Class -> [TyVar]
classTyVars Class
clas [TyVar] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
inst_tys)
            mini_subst :: Subst
mini_subst = InScopeSet -> VarEnv Type -> Subst
mkTvSubst ([TyVar] -> InScopeSet
mkInScopeSetList [TyVar]
tyvars) VarEnv Type
mini_env
        DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        [[FamInst]]
tyfam_insts <-
          -- canDeriveAnyClass should ensure that this code can't be reached
          -- unless -XDeriveAnyClass is enabled.
          Bool
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
                    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genFamInsts: bad derived class" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
clas) (IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
 -> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]])
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall a b. (a -> b) -> a -> b
$
          (ClassATItem -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [ClassATItem] -> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (SrcSpan
-> Subst
-> Uses
-> ClassATItem
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
tcATDefault SrcSpan
loc Subst
mini_subst Uses
emptyNameSet)
               (Class -> [ClassATItem]
classATItems Class
clas)
        [FamInst] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FamInst] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [FamInst] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall a b. (a -> b) -> a -> b
$ [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
tyfam_insts

      -- Try DerivingVia
      DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty}
        -> Type -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_newtype_or_via Type
via_ty
  where
    gen_newtype_or_via :: Type -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_newtype_or_via Type
ty = SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_Newtype_fam_insts SrcSpan
loc Class
clas [TyVar]
tyvars [Type]
inst_tys Type
ty

-- Set the SrcSpan and error context for an action that uses a DerivSpec.
set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt :: forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt (DS{ ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
tys }) =
  SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn a -> TcRn a) -> (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Class -> [Type] -> SDoc
instDeclCtxt3 Class
clas [Type]
tys)

-- Checks:
--
-- * All of the data constructors for a data type are in scope for a
--   standalone-derived instance (for `stock` and `newtype` deriving).
--
-- * All of the associated type families of a class are suitable for
--   GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via`
--   deriving).
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 :: DerivSpecMechanism -> ReaderT DerivEnv TcRn ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism =
  case DerivSpecMechanism
mechanism of
    DerivSpecStock{dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit}
      -> DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check DerivInstTys
dit
    -- No need to 'data_cons_in_scope_check' for newtype deriving.
    -- Additionally, we also don't need to mark the constructos as
    -- used because newtypes are handled separately elsewhere.
    -- See Note [Tracking unused binding and imports] in GHC.Tc.Types
    -- or #17328 for more.
    DerivSpecNewtype{}
      -> ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
    DerivSpecAnyClass{}
      -> () -> ReaderT DerivEnv TcRn ()
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    DerivSpecVia{}
      -> ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
  where
    -- When processing a standalone deriving declaration, check that all of the
    -- constructors for the data type are in scope. For instance:
    --
    --   import M (T)
    --   deriving stock instance Eq T
    --
    -- This should be rejected, as the derived Eq instance would need to refer
    -- to the constructors for T, which are not in scope.
    --
    -- Note that the only strategies that require this check are `stock` and
    -- `newtype`. Neither `anyclass` nor `via` require it as the code that they
    -- generate does not require using data constructors.
    data_cons_in_scope_check :: DerivInstTys -> DerivM ()
    data_cons_in_scope_check :: DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc     = TyCon
tc
                                           , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
      Bool
standalone <- DerivM Bool
isStandaloneDeriv
      Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ do
        let bale_out :: DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out DeriveInstanceErrReason
msg = do TcRnMessage
err <- DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
msg
                              TcRn () -> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
err

        GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv -> ReaderT DerivEnv TcRn GlobalRdrEnv
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn GlobalRdrEnv
getGlobalRdrEnv
        let data_con_names :: [Name]
data_con_names = (DataCon -> Name) -> [DataCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Name
dataConName (TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc)
            hidden_data_cons :: Bool
hidden_data_cons = Bool -> Bool
not (TyCon -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn TyCon
rep_tc) Bool -> Bool -> Bool
&&
                               (TyCon -> Bool
isAbstractTyCon TyCon
rep_tc Bool -> Bool -> Bool
||
                                (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
not_in_scope [Name]
data_con_names)
            not_in_scope :: Name -> Bool
not_in_scope Name
dc  = Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc)

        -- Make sure to also mark the data constructors as used so that GHC won't
        -- mistakenly emit -Wunused-imports warnings about them.
        TcRn () -> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> TyCon -> TcRn ()
addUsedDataCons GlobalRdrEnv
rdr_env TyCon
rep_tc

        Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
hidden_data_cons) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
          DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out (DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ())
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrDataConsNotAllInScope TyCon
tc

    -- Ensure that a class's associated type variables are suitable for
    -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is
    -- only required for the `newtype` and `via` strategies.
    --
    -- See Note [GND and associated type families]
    atf_coerce_based_error_checks :: DerivM ()
    atf_coerce_based_error_checks :: ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks = do
      Class
cls <- (DerivEnv -> Class) -> ReaderT DerivEnv TcRn Class
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks DerivEnv -> Class
denv_cls
      let bale_out :: DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out DeriveInstanceErrReason
msg = do TcRnMessage
err <- DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
msg
                            TcRn () -> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
err

          cls_tyvars :: [TyVar]
cls_tyvars = Class -> [TyVar]
classTyVars Class
cls

          ats_look_sensible :: Bool
ats_look_sensible
             =  -- Check (a) from Note [GND and associated type families]
                Bool
no_adfs
                -- Check (b) from Note [GND and associated type families]
             Bool -> Bool -> Bool
&& Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyCon
at_without_last_cls_tv
                -- Check (d) from Note [GND and associated type families]
             Bool -> Bool -> Bool
&& Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyCon
at_last_cls_tv_in_kinds

          ([TyCon]
adf_tcs, [TyCon]
atf_tcs) = (TyCon -> Bool) -> [TyCon] -> ([TyCon], [TyCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCon -> Bool
isDataFamilyTyCon [TyCon]
at_tcs
          no_adfs :: Bool
no_adfs            = [TyCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCon]
adf_tcs
                 -- We cannot newtype-derive data family instances

          at_without_last_cls_tv :: Maybe TyCon
at_without_last_cls_tv
            = (TyCon -> Bool) -> [TyCon] -> Maybe TyCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TyCon
tc -> TyVar
last_cls_tv TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TyCon -> [TyVar]
tyConTyVars TyCon
tc) [TyCon]
atf_tcs
          at_last_cls_tv_in_kinds :: Maybe TyCon
at_last_cls_tv_in_kinds
            = (TyCon -> Bool) -> [TyCon] -> Maybe TyCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TyCon
tc -> (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Bool
at_last_cls_tv_in_kind (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind)
                               (TyCon -> [TyVar]
tyConTyVars TyCon
tc)
                        Bool -> Bool -> Bool
|| Type -> Bool
at_last_cls_tv_in_kind (TyCon -> Type
tyConResKind TyCon
tc)) [TyCon]
atf_tcs
          at_last_cls_tv_in_kind :: Type -> Bool
at_last_cls_tv_in_kind Type
kind
            = TyVar
last_cls_tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
kind
          at_tcs :: [TyCon]
at_tcs = Class -> [TyCon]
classATs Class
cls
          last_cls_tv :: TyVar
last_cls_tv = Bool -> ([TyVar] -> TyVar) -> [TyVar] -> TyVar
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [TyVar]
cls_tyvars )
                        [TyVar] -> TyVar
forall a. HasCallStack => [a] -> a
last [TyVar]
cls_tyvars

      Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ats_look_sensible (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
        DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out (HasAssociatedDataFamInsts
-> AssociatedTyLastVarInKind
-> AssociatedTyNotParamOverLastTyVar
-> DeriveInstanceErrReason
DerivErrHasAssociatedDatatypes
                   (Bool -> HasAssociatedDataFamInsts
hasAssociatedDataFamInsts (Bool -> Bool
not Bool
no_adfs))
                   (Maybe TyCon -> AssociatedTyLastVarInKind
associatedTyLastVarInKind Maybe TyCon
at_last_cls_tv_in_kinds)
                   (Maybe TyCon -> AssociatedTyNotParamOverLastTyVar
associatedTyNotParamOverLastTyVar Maybe TyCon
at_without_last_cls_tv)
                 )

doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
                        -> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 :: Class
-> ClsInst
-> [Type]
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
clas_inst [Type]
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
  = do { String -> SDoc -> TcRn ()
traceTc String
"doDerivInstErrorChecks2" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
clas_inst)
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; Bool
xpartial_sigs <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
       ; Bool
wpartial_sigs <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures

         -- Error if PartialTypeSignatures isn't enabled when a user tries
         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
         -- extension is enabled, give a warning if -Wpartial-type-signatures
         -- is enabled.
       ; case Maybe SrcSpan
wildcard of
           Maybe SrcSpan
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           Just SrcSpan
span -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
span (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
             let suggParSigs :: SuggestPartialTypeSignatures
suggParSigs = Bool -> SuggestPartialTypeSignatures
suggestPartialTypeSignatures Bool
xpartial_sigs
             let dia :: TcRnMessage
dia = SuggestPartialTypeSignatures -> [Type] -> TcRnMessage
TcRnPartialTypeSignatures SuggestPartialTypeSignatures
suggParSigs [Type]
theta
             Bool -> TcRnMessage -> TcRn ()
checkTc Bool
xpartial_sigs TcRnMessage
dia
             Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
wpartial_sigs TcRnMessage
dia

         -- Check for Generic instances that are derived with an exotic
         -- deriving strategy like DAC
         -- See Note [Deriving strategies]
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exotic_mechanism Bool -> Bool -> Bool
&& Class -> Name
className Class
clas Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
genericClassNames) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         do { Bool -> TcRnMessage -> TcRn ()
failIfTc (DynFlags -> Bool
safeLanguageOn DynFlags
dflags)
                       (Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
clas [Type]
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                          DeriveInstanceErrReason
DerivErrSafeHaskellGenericInst)
            ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeInferOn DynFlags
dflags) (Messages TcRnMessage -> TcRn ()
recordUnsafeInfer Messages TcRnMessage
forall e. Messages e
emptyMessages) } }
  where
    exotic_mechanism :: Bool
exotic_mechanism = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DerivSpecMechanism -> Bool
isDerivSpecStock DerivSpecMechanism
mechanism

derivingThingFailWith :: UsingGeneralizedNewtypeDeriving
                         -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about
                         -- how not even GeneralizedNewtypeDeriving would make this
                         -- declaration work. This only kicks in when
                         -- an explicit deriving strategy is not given.
                      -> DeriveInstanceErrReason -- The reason the derivation failed
                      -> DerivM a
derivingThingFailWith :: forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
msg = do
  TcRnMessage
err <- UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrM UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
msg
  TcRn a -> DerivM a
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn a -> DerivM a) -> TcRn a -> DerivM a
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn a
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
err

{-
Note [Bindings for Generalised Newtype Deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  class Eq a => C a where
     f :: a -> a
  newtype N a = MkN [a] deriving( C )
  instance Eq (N a) where ...

The 'deriving C' clause generates, in effect
  instance (C [a], Eq a) => C (N a) where
     f = coerce (f :: [a] -> [a])

This generates a cast for each method, but allows the superclasses to
be worked out in the usual way.  In this case the superclass (Eq (N
a)) will be solved by the explicit Eq (N a) instance.  We do *not*
create the superclasses by casting the superclass dictionaries for the
representation type.

See the paper "Safe zero-cost coercions for Haskell".

Note [DeriveAnyClass and default family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When a class has a associated type family with a default instance, e.g.:

  class C a where
    type T a
    type T a = Char

then there are a couple of scenarios in which a user would expect T a to
default to Char. One is when an instance declaration for C is given without
an implementation for T:

  instance C Int

Another scenario in which this can occur is when the -XDeriveAnyClass extension
is used:

  data Example = Example deriving (C, Generic)

In the latter case, we must take care to check if C has any associated type
families with default instances, because -XDeriveAnyClass will never provide
an implementation for them. We "fill in" the default instances using the
tcATDefault function from GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance to
handle the empty instance declaration case).

Note [Deriving strategies]
~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC has a notion of deriving strategies, which allow the user to explicitly
request which approach to use when deriving an instance (enabled with the
-XDerivingStrategies language extension). For more information, refer to the
original issue (#10598) or the associated wiki page:
https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies

A deriving strategy can be specified in a deriving clause:

    newtype Foo = MkFoo Bar
      deriving newtype C

Or in a standalone deriving declaration:

    deriving anyclass instance C Foo

-XDerivingStrategies also allows the use of multiple deriving clauses per data
declaration so that a user can derive some instance with one deriving strategy
and other instances with another deriving strategy. For example:

    newtype Baz = Baz Quux
      deriving          (Eq, Ord)
      deriving stock    (Read, Show)
      deriving newtype  (Num, Floating)
      deriving anyclass C

Currently, the deriving strategies are:

* stock: Have GHC implement a "standard" instance for a data type, if possible
  (e.g., Eq, Ord, Generic, Data, Functor, etc.)

* anyclass: Use -XDeriveAnyClass

* newtype: Use -XGeneralizedNewtypeDeriving

* via: Use -XDerivingVia

The latter two strategies (newtype and via) are referred to as the
"coerce-based" strategies, since they generate code that relies on the `coerce`
function. See, for instance, GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased.

The former two strategies (stock and anyclass), in contrast, are
referred to as the "originative" strategies, since they create "original"
instances instead of "reusing" old instances (by way of `coerce`).
See, for instance, GHC.Tc.Deriv.Utils.checkOriginativeSideConditions.

If an explicit deriving strategy is not given, GHC has an algorithm it uses to
determine which strategy it will actually use. The algorithm is quite long,
so it lives in the Haskell wiki at
https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
("The deriving strategy resolution algorithm" section).

Internally, GHC uses the DerivStrategy datatype to denote a user-requested
deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
GHC will use to derive the instance after taking the above steps. In other
words, GHC will always settle on a DerivSpecMechnism, even if the user did not
ask for a particular DerivStrategy (using the algorithm linked to above).

Note [Deriving instances for classes themselves]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Much of the code in GHC.Tc.Deriv assumes that deriving only works on data types.
But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
reasonable to do something like this:

  {-# LANGUAGE DeriveAnyClass #-}
  class C1 (a :: Constraint) where
  class C2 where
  deriving instance C1 C2
    -- This is equivalent to `instance C1 C2`

If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
deriving), we throw a special error message indicating that DeriveAnyClass is
the only way to go. We don't bother throwing this error if an explicit 'stock'
or 'newtype' keyword is used, since both options have their own perfectly
sensible error messages in the case of the above code (as C1 isn't a stock
derivable class, and C2 isn't a newtype).

************************************************************************
*                                                                      *
What con2tag/tag2con functions are available?
*                                                                      *
************************************************************************
-}

derivingThingErrM :: UsingGeneralizedNewtypeDeriving
                  -> DeriveInstanceErrReason
                  -> DerivM TcRnMessage
derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrM UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why
  = do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls      = Class
cls
                , denv_inst_tys :: DerivEnv -> [Type]
denv_inst_tys = [Type]
cls_args
                , denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat    = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       TcRnMessage -> DerivM TcRnMessage
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcRnMessage -> DerivM TcRnMessage)
-> TcRnMessage -> DerivM TcRnMessage
forall a b. (a -> b) -> a -> b
$ Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
cls_args Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why

derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
why
  = do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls      = Class
cls
                , denv_inst_tys :: DerivEnv -> [Type]
denv_inst_tys = [Type]
cls_args
                , denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat    = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       TcRnMessage -> DerivM TcRnMessage
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcRnMessage -> DerivM TcRnMessage)
-> TcRnMessage -> DerivM TcRnMessage
forall a b. (a -> b) -> a -> b
$ Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
cls_args Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why
  where
    newtype_deriving :: UsingGeneralizedNewtypeDeriving
    newtype_deriving :: UsingGeneralizedNewtypeDeriving
newtype_deriving
      = if DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism then UsingGeneralizedNewtypeDeriving
YesGeneralizedNewtypeDeriving
                                        else UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving

standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
ty = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the stand-alone deriving instance for")
                       Int
2 (SDoc -> SDoc
quotes (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty))