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


Handles @deriving@ clauses on @data@ declarations.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}

module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where

#include "HsVersions.h"

import GhcPrelude

import HsSyn
import DynFlags

import TcRnMonad
import FamInst
import TcDerivInfer
import TcDerivUtils
import TcValidity( allDistinctTyVars )
import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
import TcEnv
import TcGenDeriv                       -- Deriv stuff
import TcValidity( checkValidInstHead )
import InstEnv
import Inst
import FamInstEnv
import TcHsType
import TyCoRep

import RnNames( extendGlobalRdrEnvRn )
import RnBinds
import RnEnv
import RnUtils    ( bindLocalNamesFV )
import RnSource   ( addTcgDUs )
import Avail

import Unify( tcUnifyTy )
import Class
import Type
import ErrUtils
import DataCon
import Maybes
import RdrName
import Name
import NameSet
import TyCon
import TcType
import Var
import VarEnv
import VarSet
import PrelNames
import SrcLoc
import Util
import Outputable
import FastString
import Bag
import Pair
import FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List

{-
************************************************************************
*                                                                      *
                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 [ThetaOrigin])
                    | 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 TcDerivInfer

earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc :: EarlyDerivSpec -> SrcSpan
earlyDSLoc (InferTheta spec :: DerivSpec [ThetaOrigin]
spec) = DerivSpec [ThetaOrigin] -> SrcSpan
forall theta. DerivSpec theta -> SrcSpan
ds_loc DerivSpec [ThetaOrigin]
spec
earlyDSLoc (GivenTheta spec :: DerivSpec ThetaType
spec) = DerivSpec ThetaType -> SrcSpan
forall theta. DerivSpec theta -> SrcSpan
ds_loc DerivSpec ThetaType
spec

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

instance Outputable EarlyDerivSpec where
  ppr :: EarlyDerivSpec -> SDoc
ppr (InferTheta spec :: DerivSpec [ThetaOrigin]
spec) = DerivSpec [ThetaOrigin] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec [ThetaOrigin]
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "(Infer)"
  ppr (GivenTheta spec :: DerivSpec ThetaType
spec) = DerivSpec ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec ThetaType
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "(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 [Newtype deriving superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(See also Trac #1220 for an interesting exchange on newtype
deriving and superclasses.)

The 'tys' here come from the partial application in the deriving
clause. The last arg is the new instance type.

We must pass the superclasses; the newtype might be an instance
of them in a different way than the representation type
E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
Then the Show instance is not done via Coercible; it shows
        Foo 3 as "Foo 3"
The Num instance is derived via Coercible, but the Show superclass
dictionary must the Show instance for Foo, *not* the Show dictionary
gotten from the Num dictionary. So we must build a whole new dictionary
not just use the Num one.  The instance we want is something like:
     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
        (+) = ((+)@a)
        ...etc...
There may be a coercion needed which we get from the tycon for the newtype
when the dict is constructed in TcInstDcls.tcInstDecl2


Note [Unused constructors and deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #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 -> [LHsDerivingClause GhcRn]
di_clauses :: [LHsDerivingClause GhcRn]
                           , DerivInfo -> SDoc
di_ctxt    :: SDoc -- ^ error context
                           }

-- | Extract `deriving` clauses of proper data type (skips data families)
mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
mkDerivInfos decls :: [LTyClDecl GhcRn]
decls = (LTyClDecl GhcRn -> TcM [DerivInfo])
-> [LTyClDecl GhcRn] -> TcM [DerivInfo]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (TyClDecl GhcRn -> TcM [DerivInfo]
mk_deriv (TyClDecl GhcRn -> TcM [DerivInfo])
-> (LTyClDecl GhcRn -> TyClDecl GhcRn)
-> LTyClDecl GhcRn
-> TcM [DerivInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LTyClDecl GhcRn]
decls
  where

    mk_deriv :: TyClDecl GhcRn -> TcM [DerivInfo]
mk_deriv decl :: TyClDecl GhcRn
decl@(DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = L _ data_name :: IdP GhcRn
data_name
                            , tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn =
                                HsDataDefn { dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = L _ clauses :: [LHsDerivingClause GhcRn]
clauses } })
      = do { TyCon
tycon <- Name -> TcM TyCon
tcLookupTyCon Name
IdP GhcRn
data_name
           ; [DerivInfo] -> TcM [DerivInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [DerivInfo :: TyCon -> [LHsDerivingClause GhcRn] -> SDoc -> DerivInfo
DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon, di_clauses :: [LHsDerivingClause GhcRn]
di_clauses = [LHsDerivingClause GhcRn]
clauses
                               , di_ctxt :: SDoc
di_ctxt = TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl }] }
    mk_deriv _ = [DerivInfo] -> TcM [DerivInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []

{-

************************************************************************
*                                                                      *
\subsection[TcDeriv-driver]{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 deriv_infos :: [DerivInfo]
deriv_infos deriv_decls :: [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 (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 TcEnv
                -- And make the necessary "equations".
          Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
        ; String -> SDoc -> TcRn ()
traceTc "tcDeriving" (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
is_boot)

        ; [EarlyDerivSpec]
early_specs <- Bool -> [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs Bool
is_boot [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
        ; String -> SDoc -> TcRn ()
traceTc "tcDeriving 1" ([EarlyDerivSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EarlyDerivSpec]
early_specs)

        ; let (infer_specs :: [DerivSpec [ThetaOrigin]]
infer_specs, given_specs :: [DerivSpec ThetaType]
given_specs) = [EarlyDerivSpec]
-> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
early_specs
        ; [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1 <- (DerivSpec ThetaType
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]))
-> [DerivSpec ThetaType]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec ThetaType
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall theta.
DerivSpec theta
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst [DerivSpec ThetaType]
given_specs
        ; [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2 <- (DerivSpec [ThetaOrigin]
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]))
-> [DerivSpec [ThetaOrigin]]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec [ThetaOrigin]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall theta.
DerivSpec theta
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst [DerivSpec [ThetaOrigin]]
infer_specs

        ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

        ; let (_, deriv_stuff :: [BagDerivStuff]
deriv_stuff, fvs :: [[Name]]
fvs) = [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> ([ThetaType -> TcM (InstInfo GhcPs)], [BagDerivStuff], [[Name]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1 [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
forall a. [a] -> [a] -> [a]
++ [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2)
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; let (binds :: Bag (LHsBind GhcPs, LSig GhcPs)
binds, famInsts :: Bag FamInst
famInsts) = DynFlags
-> SrcSpan
-> BagDerivStuff
-> (Bag (LHsBind GhcPs, LSig GhcPs), Bag FamInst)
genAuxBinds DynFlags
dflags SrcSpan
loc
                                    ([BagDerivStuff] -> BagDerivStuff
forall a. [Bag a] -> Bag a
unionManyBags [BagDerivStuff]
deriv_stuff)

        ; let mk_inst_infos1 :: [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos1 = ((ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
 -> ThetaType -> TcM (InstInfo GhcPs))
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [ThetaType -> TcM (InstInfo GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> ThetaType -> TcM (InstInfo GhcPs)
forall a b c. (a, b, c) -> a
fstOf3 [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts1
        ; [InstInfo GhcPs]
inst_infos1 <- [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos1 [DerivSpec ThetaType]
given_specs

          -- 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 (Bag FamInst -> [FamInst]
forall a. Bag a -> [a]
bagToList Bag 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 {
        -- the stand-alone derived instances (@inst_infos1@) are used when
        -- inferring the contexts for "deriving" clauses' instances
        -- (@infer_specs@)
        ; [DerivSpec ThetaType]
final_specs <- [ClsInst] -> TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType]
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]
inst_infos1) (TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType])
-> TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType]
forall a b. (a -> b) -> a -> b
$
                         [DerivSpec [ThetaOrigin]] -> TcM [DerivSpec ThetaType]
simplifyInstanceContexts [DerivSpec [ThetaOrigin]]
infer_specs

        ; let mk_inst_infos2 :: [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos2 = ((ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
 -> ThetaType -> TcM (InstInfo GhcPs))
-> [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
-> [ThetaType -> TcM (InstInfo GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> ThetaType -> TcM (InstInfo GhcPs)
forall a b c. (a, b, c) -> a
fstOf3 [(ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])]
insts2
        ; [InstInfo GhcPs]
inst_infos2 <- [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos [ThetaType -> TcM (InstInfo GhcPs)]
mk_inst_infos2 [DerivSpec ThetaType]
final_specs
        ; let inst_infos :: [InstInfo GhcPs]
inst_infos = [InstInfo GhcPs]
inst_infos1 [InstInfo GhcPs] -> [InstInfo GhcPs] -> [InstInfo GhcPs]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcPs]
inst_infos2

        ; (inst_info :: Bag (InstInfo GhcRn)
inst_info, rn_binds :: HsValBinds GhcRn
rn_binds, rn_dus :: DefUses
rn_dus) <-
            Bool
-> [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv Bool
is_boot [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_deriv "Derived instances"
                        (Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> Bag FamInst -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_info HsValBinds GhcRn
rn_binds Bag 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 (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_binds) } }
  where
    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
                   -> Bag FamInst             -- ^ Rep type family instances
                   -> SDoc
    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> Bag FamInst -> SDoc
ddump_deriving inst_infos :: Bag (InstInfo GhcRn)
inst_infos extra_binds :: HsValBinds GhcRn
extra_binds repFamInsts :: Bag FamInst
repFamInsts
      =    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Derived class instances:")
              2 ([SDoc] -> SDoc
vcat ((InstInfo GhcRn -> SDoc) -> [InstInfo GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\i :: InstInfo GhcRn
i -> InstInfo GhcRn -> SDoc
forall (a :: Pass).
OutputableBndrId (GhcPass a) =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcRn
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "") (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_infos))
                 SDoc -> SDoc -> SDoc
$$ HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
extra_binds)
        SDoc -> SDoc -> SDoc
$$ String -> SDoc -> SDoc
hangP "Derived type family instances:"
             ([SDoc] -> SDoc
vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
pprRepTy (Bag FamInst -> [FamInst]
forall a. Bag a -> [a]
bagToList Bag FamInst
repFamInsts)))

    hangP :: String -> SDoc -> SDoc
hangP s :: String
s x :: SDoc
x = String -> SDoc
text "" SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang (PtrString -> SDoc
ptext (String -> PtrString
sLit String
s)) 2 SDoc
x

    -- Apply the suspended computations given by genInst calls.
    -- See Note [Staging of tcDeriving]
    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
apply_inst_infos = ((ThetaType -> TcM (InstInfo GhcPs))
 -> DerivSpec ThetaType -> TcM (InstInfo GhcPs))
-> [ThetaType -> TcM (InstInfo GhcPs)]
-> [DerivSpec ThetaType]
-> TcM [InstInfo GhcPs]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\f :: ThetaType -> TcM (InstInfo GhcPs)
f ds :: DerivSpec ThetaType
ds -> ThetaType -> TcM (InstInfo GhcPs)
f (DerivSpec ThetaType -> ThetaType
forall theta. DerivSpec theta -> theta
ds_theta DerivSpec ThetaType
ds))

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

renameDeriv :: Bool
            -> [InstInfo GhcPs]
            -> Bag (LHsBind GhcPs, LSig GhcPs)
            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv :: Bool
-> [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv is_boot :: Bool
is_boot inst_infos :: [InstInfo GhcPs]
inst_infos bagBinds :: Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
  | Bool
is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
                -- The inst-info bindings will all be empty, but it's easier to
                -- just use rn_inst_info to change the type appropriately
  = do  { (rn_inst_infos :: [InstInfo GhcRn]
rn_inst_infos, fvs :: [Uses]
fvs) <- (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 (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
forall (a :: Pass) (b :: Pass).
HsValBindsLR (GhcPass a) (GhcPass b)
emptyValBindsOut, Uses -> DefUses
usesOnly ([Uses] -> Uses
plusFVs [Uses]
fvs)) }

  | Bool
otherwise
  = 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 TcGenDeriv)
    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]
    do  {
        -- Bring the extra deriving stuff into scope
        -- before renaming the instances themselves
        ; String -> SDoc -> TcRn ()
traceTc "rnd" ([SDoc] -> SDoc
vcat ((InstInfo GhcPs -> SDoc) -> [InstInfo GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\i :: InstInfo GhcPs
i -> InstInfo GhcPs -> SDoc
forall (a :: Pass).
OutputableBndrId (GhcPass a) =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcPs
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "") [InstInfo GhcPs]
inst_infos))
        ; (aux_binds :: Bag (LHsBind GhcPs)
aux_binds, aux_sigs :: Bag (LSig GhcPs)
aux_sigs) <- ((LHsBind GhcPs, LSig GhcPs)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LHsBind GhcPs, LSig GhcPs))
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Bag (LHsBind GhcPs), Bag (LSig GhcPs))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (b, c)) -> Bag a -> m (Bag b, Bag c)
mapAndUnzipBagM (LHsBind GhcPs, LSig GhcPs)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsBind GhcPs, LSig GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
        ; let aux_val_binds :: HsValBindsLR GhcPs GhcPs
aux_val_binds = XValBinds GhcPs GhcPs
-> Bag (LHsBind GhcPs) -> [LSig GhcPs] -> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
NoExt
noExt Bag (LHsBind GhcPs)
aux_binds (Bag (LSig GhcPs) -> [LSig GhcPs]
forall a. Bag a -> [a]
bagToList Bag (LSig GhcPs)
aux_sigs)
        ; HsValBindsLR GhcRn GhcPs
rn_aux_lhs <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs -> RnM (HsValBindsLR GhcRn GhcPs)
rnTopBindsLHS MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv HsValBindsLR GhcPs GhcPs
aux_val_binds
        ; let bndrs :: [IdP GhcRn]
bndrs = HsValBindsLR GhcRn GhcPs -> [IdP GhcRn]
forall (idL :: Pass) (idR :: Pass).
HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsValBinders HsValBindsLR GhcRn GhcPs
rn_aux_lhs
        ; (TcGblEnv, TcLclEnv)
envs <- [AvailInfo] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv)
extendGlobalRdrEnvRn ((Name -> AvailInfo) -> [Name] -> [AvailInfo]
forall a b. (a -> b) -> [a] -> [b]
map Name -> AvailInfo
avail [Name]
[IdP GhcRn]
bndrs) MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv ;
        ; (TcGblEnv, TcLclEnv)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv, TcLclEnv)
envs (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  { (rn_aux :: HsValBinds GhcRn
rn_aux, dus_aux :: DefUses
dus_aux) <- HsSigCtxt
-> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnValBindsRHS (Uses -> HsSigCtxt
TopSigCtxt ([Name] -> Uses
mkNameSet [Name]
[IdP GhcRn]
bndrs)) HsValBindsLR GhcRn GhcPs
rn_aux_lhs
        ; (rn_inst_infos :: [InstInfo GhcRn]
rn_inst_infos, fvs_insts :: [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 (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 = Bag (LHsBind 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 } })
        =  ASSERT( null sigs )
           [Name]
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall a. [Name] -> RnM (a, Uses) -> RnM (a, Uses)
bindLocalNamesFV [Name]
tyvars (IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
 -> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses))
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall a b. (a -> b) -> a -> b
$
           do { (rn_binds :: LHsBinds GhcRn
rn_binds,_, fvs :: Uses
fvs) <- Bool
-> Name
-> [Name]
-> Bag (LHsBind GhcPs)
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], Uses)
rnMethodBinds Bool
False (ClsInst -> Name
is_cls_nm ClsInst
inst) [] Bag (LHsBind GhcPs)
binds []
              ; let binds' :: InstBindings GhcRn
binds' = InstBindings :: forall a.
[Name]
-> LHsBinds a -> [LSig a] -> [Extension] -> Bool -> InstBindings a
InstBindings { ib_binds :: LHsBinds GhcRn
ib_binds = LHsBinds GhcRn
rn_binds
                                          , ib_tyvars :: [Name]
ib_tyvars = [Name]
tyvars
                                          , ib_pragmas :: [LSig GhcRn]
ib_pragmas = []
                                          , 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 (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs
inst_info { iBinds :: InstBindings GhcRn
iBinds = InstBindings GhcRn
binds' }, Uses
fvs) }

{-
Note [Newtype deriving and unused constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (see Trac #1954):

  module Bug(P) where
  newtype P a = MkP (IO a) deriving Monad

If you compile with -Wunused-binds you do not expect the warning
"Defined but not used: data constructor MkP". Yet the newtype deriving
code does not explicitly mention MkP, but it should behave as if you
had written
  instance Monad P where
     return x = MkP (return x)
     ...etc...

So we want to signal a user of the data constructor 'MkP'.
This is the reason behind the [Name] part of the return type
of genInst.

Note [Staging of tcDeriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a tricky corner case for deriving (adapted from Trac #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 carefully structure the order of events in
tcDeriving. We first call genInst on the standalone derived instance specs and
the instance specs obtained from deriving clauses. Note that the return type of
genInst is a triple:

    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)

The type family instances are in the BagDerivStuff. The first field of the
triple is a suspended computation which, given an instance context, produces
the rest of the instance. The fact that it is suspended is important, because
right now, we don't have ThetaTypes for the instances that use deriving clauses
(only the standalone-derived ones).

Now we can can collect the type family instances and extend the local instance
environment. At this point, it is safe to run simplifyInstanceContexts on the
deriving-clause instance specs, which gives us the ThetaTypes for the
deriving-clause instances. Now we can feed all the ThetaTypes to the
suspended computations and obtain our InstInfos, at which point
tcDeriving is done.

An alternative design would be to split up genInst so that the
family instances are generated separately from the InstInfos. But this would
require carving up a lot of the GHC deriving internals to accommodate the
change. On the other hand, we can keep all of the InstInfo and type family
instance logic together in genInst simply by converting genInst to
continuation-returning style, so we opt for that route.

Note [Why we don't pass rep_tc into deriveTyData]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Down in the bowels of mkEqnHelp, 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 Trac #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 :: Bool
               -> [DerivInfo]
               -> [LDerivDecl GhcRn]
               -> TcM [EarlyDerivSpec]
makeDerivSpecs :: Bool -> [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs is_boot :: Bool
is_boot deriv_infos :: [DerivInfo]
deriv_infos deriv_decls :: [LDerivDecl GhcRn]
deriv_decls
  = do  { -- We carefully set up uses of recoverM to minimize error message
          -- cascades. See Note [Flattening deriving clauses].
        ; [Maybe EarlyDerivSpec]
eqns1 <- [IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe EarlyDerivSpec]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
                     [ 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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EarlyDerivSpec
forall a. Maybe a
Nothing)
                                (TyCon
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveClause TyCon
rep_tc ((LDerivStrategy GhcRn -> DerivStrategy GhcRn)
-> Maybe (LDerivStrategy GhcRn) -> Maybe (DerivStrategy GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LDerivStrategy GhcRn -> DerivStrategy GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (LDerivStrategy GhcRn)
dcs)
                                                      LHsSigType GhcRn
pred SDoc
err_ctxt)
                     | DerivInfo { di_rep_tc :: DerivInfo -> TyCon
di_rep_tc = TyCon
rep_tc, di_clauses :: DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses = [LHsDerivingClause GhcRn]
clauses
                                 , di_ctxt :: DerivInfo -> SDoc
di_ctxt = SDoc
err_ctxt } <- [DerivInfo]
deriv_infos
                     , L _ (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 -> Located [LHsSigType pass]
deriv_clause_tys = L _ preds :: [LHsSigType GhcRn]
preds })
                         <- [LHsDerivingClause GhcRn]
clauses
                     , LHsSigType GhcRn
pred <- [LHsSigType GhcRn]
preds
                     ]
        ; [Maybe EarlyDerivSpec]
eqns2 <- (LDerivDecl GhcRn
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [LDerivDecl GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe EarlyDerivSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 (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))
-> (LDerivDecl GhcRn
    -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> LDerivDecl 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)
deriveStandalone) [LDerivDecl GhcRn]
deriv_decls
        ; let eqns :: [EarlyDerivSpec]
eqns = [Maybe EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe EarlyDerivSpec]
eqns1 [Maybe EarlyDerivSpec]
-> [Maybe EarlyDerivSpec] -> [Maybe EarlyDerivSpec]
forall a. [a] -> [a] -> [a]
++ [Maybe EarlyDerivSpec]
eqns2)

        ; if Bool
is_boot then   -- No 'deriving' at all in hs-boot files
              do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([EarlyDerivSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EarlyDerivSpec]
eqns) (EarlyDerivSpec -> TcRn ()
add_deriv_err ([EarlyDerivSpec] -> EarlyDerivSpec
forall a. [a] -> a
head [EarlyDerivSpec]
eqns))
                 ; [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall (m :: * -> *) a. Monad m => a -> m a
return [] }
          else [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall (m :: * -> *) a. Monad m => a -> m a
return [EarlyDerivSpec]
eqns }
  where
    add_deriv_err :: EarlyDerivSpec -> TcRn ()
add_deriv_err eqn :: EarlyDerivSpec
eqn
       = SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (EarlyDerivSpec -> SrcSpan
earlyDSLoc EarlyDerivSpec
eqn) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         SDoc -> TcRn ()
addErr (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Deriving not permitted in hs-boot file")
                    2 (String -> SDoc
text "Use an instance declaration instead"))

{-
Note [Flattening deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider what happens if you run this program (from Trac #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, so 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 "flatten" the set of classes that are
derived for a particular data type via deriving clauses. That is, if
you have:

    newtype C = C D
      deriving (E, F, G)
      deriving anyclass (H, I, J)
      deriving newtype  (K, L, M)

Then instead of processing instances E through M under the scope of a single
recoverM, we flatten these deriving clauses into the list:

    [ E (Nothing)
    , F (Nothing)
    , G (Nothing)
    , H (Just anyclass)
    , I (Just anyclass)
    , J (Just anyclass)
    , K (Just newtype)
    , L (Just newtype)
    , M (Just newtype) ]

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

------------------------------------------------------------------
-- | Process a single class in a `deriving` clause.
deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)
             -> LHsSigType GhcRn -> SDoc
             -> TcM (Maybe EarlyDerivSpec)
deriveClause :: TyCon
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveClause rep_tc :: TyCon
rep_tc mb_strat :: Maybe (DerivStrategy GhcRn)
mb_strat pred :: LHsSigType GhcRn
pred err_ctxt :: SDoc
err_ctxt
  = SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (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
$
    [TyVar]
-> TyCon
-> ThetaType
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveTyData [TyVar]
tvs TyCon
tc ThetaType
tys Maybe (DerivStrategy GhcRn)
mb_strat LHsSigType GhcRn
pred
  where
    tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
    (tc :: TyCon
tc, tys :: ThetaType
tys) = case TyCon -> Maybe (TyCon, ThetaType, CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
rep_tc of
                        -- data family:
                  Just (fam_tc :: TyCon
fam_tc, pats :: ThetaType
pats, _) -> (TyCon
fam_tc, ThetaType
pats)
      -- NB: deriveTyData wants the *user-specified*
      -- name. See Note [Why we don't pass rep_tc into deriveTyData]

                  _ -> (TyCon
rep_tc, [TyVar] -> ThetaType
mkTyVarTys [TyVar]
tvs)     -- datatype

------------------------------------------------------------------
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 loc :: SrcSpan
loc (DerivDecl _ deriv_ty :: LHsSigWcType GhcRn
deriv_ty mbl_deriv_strat :: Maybe (LDerivStrategy GhcRn)
mbl_deriv_strat overlap_mode :: Maybe (Located OverlapMode)
overlap_mode))
  = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 "Standalone deriving decl for" (LHsSigWcType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
deriv_ty)
       ; let mb_deriv_strat :: Maybe (DerivStrategy GhcRn)
mb_deriv_strat = (LDerivStrategy GhcRn -> DerivStrategy GhcRn)
-> Maybe (LDerivStrategy GhcRn) -> Maybe (DerivStrategy GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LDerivStrategy GhcRn -> DerivStrategy GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (LDerivStrategy GhcRn)
mbl_deriv_strat
             ctxt :: UserTypeCtxt
ctxt           = Bool -> UserTypeCtxt
TcType.InstDeclCtxt Bool
True
       ; String -> SDoc -> TcRn ()
traceTc "Deriving strategy (standalone deriving)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [Maybe (DerivStrategy GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcRn)
mb_deriv_strat, LHsSigWcType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
deriv_ty]
       ; (mb_deriv_strat' :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat', tvs' :: [TyVar]
tvs', (deriv_ctxt' :: DerivContext
deriv_ctxt', cls :: Class
cls, inst_tys' :: ThetaType
inst_tys'))
           <- Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], (DerivContext, Class, ThetaType))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (DerivContext, Class, ThetaType))
forall a.
Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], a)
-> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
tcDerivStrategy Maybe (DerivStrategy GhcRn)
mb_deriv_strat (TcM ([TyVar], (DerivContext, Class, ThetaType))
 -> TcM
      (Maybe (DerivStrategy GhcTc), [TyVar],
       (DerivContext, Class, ThetaType)))
-> TcM ([TyVar], (DerivContext, Class, ThetaType))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (DerivContext, Class, ThetaType))
forall a b. (a -> b) -> a -> b
$ do
                (tvs :: [TyVar]
tvs, deriv_ctxt :: DerivContext
deriv_ctxt, cls :: Class
cls, inst_tys :: ThetaType
inst_tys)
                  <- UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, ThetaType)
tcStandaloneDerivInstType UserTypeCtxt
ctxt LHsSigWcType GhcRn
deriv_ty
                ([TyVar], (DerivContext, Class, ThetaType))
-> TcM ([TyVar], (DerivContext, Class, ThetaType))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, (DerivContext
deriv_ctxt, Class
cls, ThetaType
inst_tys))
       ; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not (ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
inst_tys')) SDoc
derivingNullaryErr
       ; let inst_ty' :: Type
inst_ty' = ThetaType -> Type
forall a. [a] -> a
last ThetaType
inst_tys'
         -- See Note [Unify kinds in deriving]
       ; (tvs :: [TyVar]
tvs, deriv_ctxt :: DerivContext
deriv_ctxt, inst_tys :: ThetaType
inst_tys) <-
           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 via_ty :: XViaStrategy GhcTc
via_ty) -> do
               let via_kind :: Type
via_kind     = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
XViaStrategy GhcTc
via_ty
                   inst_ty_kind :: Type
inst_ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
inst_ty'
                   mb_match :: Maybe TCvSubst
mb_match     = Type -> Type -> Maybe TCvSubst
tcUnifyTy Type
inst_ty_kind Type
via_kind

               Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
                       (Class -> Type -> Type -> Type -> SDoc
derivingViaKindErr Class
cls Type
inst_ty_kind
                                           Type
XViaStrategy GhcTc
via_ty Type
via_kind)

               let Just kind_subst :: TCvSubst
kind_subst = Maybe TCvSubst
mb_match
                   ki_subst_range :: VarSet
ki_subst_range  = TCvSubst -> VarSet
getTCvSubstRangeFVs TCvSubst
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 (\v :: TyVar
v -> TyVar
v TyVar -> TCvSubst -> Bool
`notElemTCvSubst` TCvSubst
kind_subst
                                        Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
                                          [TyVar]
tvs'
                   (subst :: TCvSubst
subst, _)    = HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
unmapped_tkvs
                   (final_deriv_ctxt :: DerivContext
final_deriv_ctxt, final_deriv_ctxt_tys :: ThetaType
final_deriv_ctxt_tys)
                     = case DerivContext
deriv_ctxt' of
                         InferContext wc :: Maybe SrcSpan
wc -> (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
wc, [])
                         SupplyContext theta :: ThetaType
theta ->
                           let final_theta :: ThetaType
final_theta = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta TCvSubst
subst ThetaType
theta
                           in (ThetaType -> DerivContext
SupplyContext ThetaType
final_theta, ThetaType
final_theta)
                   final_inst_tys :: ThetaType
final_inst_tys   = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
inst_tys'
                   final_tvs :: [TyVar]
final_tvs        = ThetaType -> [TyVar]
tyCoVarsOfTypesWellScoped (ThetaType -> [TyVar]) -> ThetaType -> [TyVar]
forall a b. (a -> b) -> a -> b
$
                                      ThetaType
final_deriv_ctxt_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
final_inst_tys
               ([TyVar], DerivContext, ThetaType)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], DerivContext, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
final_tvs, DerivContext
final_deriv_ctxt, ThetaType
final_inst_tys)

             _ -> ([TyVar], DerivContext, ThetaType)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], DerivContext, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs', DerivContext
deriv_ctxt', ThetaType
inst_tys')
       ; let cls_tys :: ThetaType
cls_tys = Int -> ThetaType -> ThetaType
forall a. Int -> [a] -> [a]
take (ThetaType -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ThetaType
inst_tys Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) ThetaType
inst_tys
             inst_ty :: Type
inst_ty = ThetaType -> Type
forall a. [a] -> a
last ThetaType
inst_tys
       ; String -> SDoc -> TcRn ()
traceTc "Standalone deriving;" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
              [ String -> SDoc
text "tvs:" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
              , String -> SDoc
text "mb_deriv_strat:" SDoc -> SDoc -> SDoc
<+> Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
              , String -> SDoc
text "deriv_ctxt:" SDoc -> SDoc -> SDoc
<+> DerivContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivContext
deriv_ctxt
              , String -> SDoc
text "cls:" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
              , String -> SDoc
text "tys:" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
inst_tys ]
                -- C.f. TcInstDcls.tcLocalInstDecl1
       ; String -> SDoc -> TcRn ()
traceTc "Standalone deriving:" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
              [ String -> SDoc
text "class:" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
              , String -> SDoc
text "class types:" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
cls_tys
              , String -> SDoc
text "type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty ]

       ; let bale_out :: SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
bale_out msg :: SDoc
msg = SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a
failWithTc (Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
False Class
cls ThetaType
cls_tys
                              Type
inst_ty Maybe (DerivStrategy GhcTc)
mb_deriv_strat' SDoc
msg)

       ; case HasCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe Type
inst_ty of
           Just (tc :: TyCon
tc, tc_args :: ThetaType
tc_args)
              | Class -> Name
className Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName
              -> do TcRn ()
warnUselessTypeable
                    Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing

              | Bool
otherwise
              -> 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
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp ((Located OverlapMode -> OverlapMode)
-> Maybe (Located OverlapMode) -> Maybe OverlapMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located OverlapMode -> OverlapMode
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (Located OverlapMode)
overlap_mode)
                                    [TyVar]
tvs Class
cls ThetaType
cls_tys TyCon
tc ThetaType
tc_args
                                    DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
mb_deriv_strat'

           _  -> -- Complain about functions, primitive types, etc,
                 SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
bale_out (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
                 String -> SDoc
text "The last argument of the instance must be a data or newtype application"
        }
deriveStandalone (L _ (XDerivDecl _)) = String -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. String -> a
panic "deriveStandalone"

-- 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 TcDerivInfer).
--
-- 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, ThetaType)
tcStandaloneDerivInstType ctxt :: UserTypeCtxt
ctxt
    (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = deriv_ty :: LHsSigType GhcRn
deriv_ty@(HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
vars
                                       , hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body   = LHsType GhcRn
deriv_ty_body })})
  | (tvs :: [LHsTyVarBndr GhcRn]
tvs, theta :: LHsContext GhcRn
theta, rho :: LHsType GhcRn
rho) <- LHsType GhcRn
-> ([LHsTyVarBndr GhcRn], LHsContext GhcRn, LHsType GhcRn)
forall pass.
LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy LHsType GhcRn
deriv_ty_body
  , L _ [wc_pred :: LHsType GhcRn
wc_pred] <- LHsContext GhcRn
theta
  , L wc_span :: SrcSpan
wc_span (HsWildCardTy _) <- LHsType GhcRn -> LHsType GhcRn
forall pass. LHsType pass -> LHsType pass
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
$
                  HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (LHsType GhcRn)
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
vars
                       , hsib_body :: LHsType GhcRn
hsib_body
                           = SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L (LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcRn
deriv_ty_body) (HsType GhcRn -> LHsType GhcRn) -> HsType GhcRn -> LHsType GhcRn
forall a b. (a -> b) -> a -> b
$
                             HsForAllTy :: forall pass.
XForAllTy pass
-> [LHsTyVarBndr pass] -> LHsType pass -> HsType pass
HsForAllTy { hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tvs
                                        , hst_xforall :: XForAllTy GhcRn
hst_xforall = XForAllTy GhcRn
NoExt
noExt
                                        , hst_body :: LHsType GhcRn
hst_body  = LHsType GhcRn
rho }}
       let (tvs :: [TyVar]
tvs, _theta :: ThetaType
_theta, cls :: Class
cls, inst_tys :: ThetaType
inst_tys) = Type -> ([TyVar], ThetaType, Class, ThetaType)
tcSplitDFunTy Type
dfun_ty
       ([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, Maybe SrcSpan -> DerivContext
InferContext (SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
wc_span), Class
cls, ThetaType
inst_tys)
  | Bool
otherwise
  = do Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt LHsSigType GhcRn
deriv_ty
       let (tvs :: [TyVar]
tvs, theta :: ThetaType
theta, cls :: Class
cls, inst_tys :: ThetaType
inst_tys) = Type -> ([TyVar], ThetaType, Class, ThetaType)
tcSplitDFunTy Type
dfun_ty
       ([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, ThetaType -> DerivContext
SupplyContext ThetaType
theta, Class
cls, ThetaType
inst_tys)

tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
  = String -> TcM ([TyVar], DerivContext, Class, ThetaType)
forall a. String -> a
panic "tcStandaloneDerivInstType"
tcStandaloneDerivInstType _ (XHsWildCardBndrs _)
  = String -> TcM ([TyVar], DerivContext, Class, ThetaType)
forall a. String -> a
panic "tcStandaloneDerivInstType"

warnUselessTypeable :: TcM ()
warnUselessTypeable :: TcRn ()
warnUselessTypeable
  = do { Bool
warn <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnDerivingTypeable
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> SDoc -> TcRn ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDerivingTypeable)
                   (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Deriving" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
typeableClassName) SDoc -> SDoc -> SDoc
<+>
                     String -> SDoc
text "has no effect: all types now auto-derive Typeable" }

------------------------------------------------------------------
deriveTyData :: [TyVar] -> 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 GhcRn)  -- The optional deriving strategy
             -> LHsSigType GhcRn             -- The deriving predicate
             -> TcM (Maybe EarlyDerivSpec)
-- The deriving clause of a data or newtype declaration
-- I.e. not standalone deriving
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
deriveTyData :: [TyVar]
-> TyCon
-> ThetaType
-> Maybe (DerivStrategy GhcRn)
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveTyData tvs :: [TyVar]
tvs tc :: TyCon
tc tc_args :: ThetaType
tc_args mb_deriv_strat :: Maybe (DerivStrategy GhcRn)
mb_deriv_strat deriv_pred :: LHsSigType GhcRn
deriv_pred
  = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType GhcRn -> LHsType GhcRn
forall pass. LHsSigType pass -> LHsType pass
hsSigType LHsSigType 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
$
    -- Use loc of the 'deriving' item
    do  { (mb_deriv_strat' :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat', deriv_tvs :: [TyVar]
deriv_tvs, (cls :: Class
cls, cls_tys :: ThetaType
cls_tys, cls_arg_kinds :: ThetaType
cls_arg_kinds))
                <- [TyVar]
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (Class, ThetaType, ThetaType))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (Class, ThetaType, ThetaType))
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
tvs (TcM
   (Maybe (DerivStrategy GhcTc), [TyVar],
    (Class, ThetaType, ThetaType))
 -> TcM
      (Maybe (DerivStrategy GhcTc), [TyVar],
       (Class, ThetaType, ThetaType)))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (Class, ThetaType, ThetaType))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (Class, ThetaType, ThetaType))
forall a b. (a -> b) -> a -> b
$
                -- Deriving preds may (now) mention
                -- the type variables for the type constructor, hence tcExtendTyVarenv
                -- The "deriv_pred" is a LHsType to take account of the fact that for
                -- newtype deriving we allow deriving (forall a. C [a]).

                -- Typeable is special, because Typeable :: forall k. k -> Constraint
                -- so the argument kind 'k' is not decomposable by splitKindFunTys
                -- as is the case for all other derivable type classes
                     Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], (Class, ThetaType, ThetaType))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (Class, ThetaType, ThetaType))
forall a.
Maybe (DerivStrategy GhcRn)
-> TcM ([TyVar], a)
-> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
tcDerivStrategy Maybe (DerivStrategy GhcRn)
mb_deriv_strat (TcM ([TyVar], (Class, ThetaType, ThetaType))
 -> TcM
      (Maybe (DerivStrategy GhcTc), [TyVar],
       (Class, ThetaType, ThetaType)))
-> TcM ([TyVar], (Class, ThetaType, ThetaType))
-> TcM
     (Maybe (DerivStrategy GhcTc), [TyVar],
      (Class, ThetaType, ThetaType))
forall a b. (a -> b) -> a -> b
$
                     LHsSigType GhcRn -> TcM ([TyVar], (Class, ThetaType, ThetaType))
tcHsDeriv LHsSigType GhcRn
deriv_pred

        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ThetaType
cls_arg_kinds ThetaType -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIsNot` 1) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
            SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (LHsSigType GhcRn -> SDoc
nonUnaryErr LHsSigType GhcRn
deriv_pred)
        ; let [cls_arg_kind :: Type
cls_arg_kind] = ThetaType
cls_arg_kinds
        ; 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 (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing
          else

     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 (arg_kinds :: ThetaType
arg_kinds, _)  = Type -> (ThetaType, Type)
splitFunTys Type
cls_arg_kind
              n_args_to_drop :: Int
n_args_to_drop  = ThetaType -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ThetaType
arg_kinds
              n_args_to_keep :: Int
n_args_to_keep  = ThetaType -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ThetaType
tc_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args_to_drop
                                -- See Note [tc_args and tycon arity]
              (tc_args_to_keep :: ThetaType
tc_args_to_keep, args_to_drop :: ThetaType
args_to_drop)
                              = Int -> ThetaType -> (ThetaType, ThetaType)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_args_to_keep ThetaType
tc_args
              inst_ty_kind :: Type
inst_ty_kind    = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
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 TCvSubst
mb_match        = Type -> Type -> Maybe TCvSubst
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
>= 0

        -- Check that the result really is well-kinded
        ; Bool -> SDoc -> TcRn ()
checkTc (Bool
enough_args Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
                  (TyCon -> Class -> ThetaType -> Type -> Bool -> SDoc
derivingKindErr TyCon
tc Class
cls ThetaType
cls_tys Type
cls_arg_kind Bool
enough_args)

        ; let propagate_subst :: TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> ([TyVar], ThetaType, ThetaType)
propagate_subst kind_subst :: TCvSubst
kind_subst tkvs' :: [TyVar]
tkvs' cls_tys' :: ThetaType
cls_tys' tc_args' :: ThetaType
tc_args'
                = ([TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args)
                where
                  ki_subst_range :: VarSet
ki_subst_range  = TCvSubst -> VarSet
getTCvSubstRangeFVs TCvSubst
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 (\v :: TyVar
v -> TyVar
v TyVar -> TCvSubst -> Bool
`notElemTCvSubst` TCvSubst
kind_subst
                                         Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
                                           [TyVar]
tkvs'
                  (subst :: TCvSubst
subst, _)      = HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
unmapped_tkvs
                  final_tc_args :: ThetaType
final_tc_args   = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
tc_args'
                  final_cls_tys :: ThetaType
final_cls_tys   = HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
cls_tys'
                  final_tkvs :: [TyVar]
final_tkvs      = ThetaType -> [TyVar]
tyCoVarsOfTypesWellScoped (ThetaType -> [TyVar]) -> ThetaType -> [TyVar]
forall a b. (a -> b) -> a -> b
$
                                    ThetaType
final_cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
final_tc_args

        ; 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 (ThetaType -> FV
tyCoFVsOfTypes ThetaType
tc_args_to_keep)
                             ([TyVar] -> FV
FV.mkFVs [TyVar]
deriv_tvs)
              Just kind_subst :: TCvSubst
kind_subst = Maybe TCvSubst
mb_match
              (tkvs' :: [TyVar]
tkvs', final_cls_tys' :: ThetaType
final_cls_tys', final_tc_args' :: ThetaType
final_tc_args')
                = TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> ([TyVar], ThetaType, ThetaType)
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs ThetaType
cls_tys ThetaType
tc_args_to_keep

          -- See Note [Unify kinds in deriving]
        ; (tkvs :: [TyVar]
tkvs, final_cls_tys :: ThetaType
final_cls_tys, final_tc_args :: ThetaType
final_tc_args, final_mb_deriv_strat :: 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 via_ty :: XViaStrategy GhcTc
via_ty) -> do
                let final_via_ty :: XViaStrategy GhcTc
final_via_ty   = XViaStrategy GhcTc
via_ty
                    final_via_kind :: Type
final_via_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
XViaStrategy GhcTc
final_via_ty
                    final_inst_ty_kind :: Type
final_inst_ty_kind
                              = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
final_tc_args')
                    via_match :: Maybe TCvSubst
via_match = Type -> Type -> Maybe TCvSubst
tcUnifyTy Type
final_inst_ty_kind Type
final_via_kind

                Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
via_match)
                        (Class -> Type -> Type -> Type -> SDoc
derivingViaKindErr Class
cls Type
final_inst_ty_kind
                                            Type
XViaStrategy GhcTc
final_via_ty Type
final_via_kind)

                let Just via_subst :: TCvSubst
via_subst = Maybe TCvSubst
via_match
                    (final_tkvs :: [TyVar]
final_tkvs, final_cls_tys :: ThetaType
final_cls_tys, final_tc_args :: ThetaType
final_tc_args)
                      = TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> ([TyVar], ThetaType, ThetaType)
propagate_subst TCvSubst
via_subst [TyVar]
tkvs'
                                        ThetaType
final_cls_tys' ThetaType
final_tc_args'
                ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args
                     , DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a. a -> Maybe a
Just (DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc))
-> DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> a -> b
$ XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy (XViaStrategy GhcTc -> DerivStrategy GhcTc)
-> XViaStrategy GhcTc -> DerivStrategy GhcTc
forall a b. (a -> b) -> a -> b
$ HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
via_subst Type
XViaStrategy GhcTc
via_ty
                     )

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

        ; String -> SDoc -> TcRn ()
traceTc "Deriving strategy (deriving clause)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
vcat [Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat, LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
deriv_pred]

        ; String -> SDoc -> TcRn ()
traceTc "derivTyData1" ([SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
pprTyVars [TyVar]
tvs, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
tc_args
                                       , LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
deriv_pred
                                       , [TyVar] -> SDoc
pprTyVars (ThetaType -> [TyVar]
tyCoVarsOfTypesList ThetaType
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 TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe TCvSubst
mb_match
                                       , ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
final_tc_args, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
final_cls_tys ])

        ; String -> SDoc -> TcRn ()
traceTc "derivTyData2" ([SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tkvs ])

        ; let final_tc_app :: Type
final_tc_app = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
final_tc_args
        ; Bool -> SDoc -> TcRn ()
checkTc (VarSet -> ThetaType -> Bool
allDistinctTyVars ([TyVar] -> VarSet
mkVarSet [TyVar]
tkvs) ThetaType
args_to_drop)     -- (a, b, c)
                  (Class -> ThetaType -> Type -> SDoc
derivingEtaErr Class
cls ThetaType
final_cls_tys 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 -> ThetaType -> TcRn ()
checkValidInstHead UserTypeCtxt
DerivClauseCtxt Class
cls (ThetaType -> TcRn ()) -> ThetaType -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                             ThetaType
final_cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
final_tc_app]
                -- Check that we aren't deriving an instance of a magical
                -- type like (~) or Coercible (#14916).

        ; EarlyDerivSpec
spec <- Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
forall a. Maybe a
Nothing [TyVar]
tkvs
                            Class
cls ThetaType
final_cls_tys TyCon
tc ThetaType
final_tc_args
                            (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
forall a. Maybe a
Nothing) Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
        ; String -> SDoc -> TcRn ()
traceTc "derivTyData" (EarlyDerivSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr EarlyDerivSpec
spec)
        ; Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EarlyDerivSpec
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$ EarlyDerivSpec -> Maybe EarlyDerivSpec
forall a. a -> Maybe a
Just 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 FamInstEnv

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

Note [Unify kinds in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (Trac #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 (Trac #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 Trac #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 Trac #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 Trac #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. Trac #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 suprisingly 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 (`notElemTCvSubst` 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 Trac #11837).

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

1. Appears in the domain of kind_subst. notElemTCvSubst 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 getTCvSubstRangeFVs, 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 Trac #11416,
where this was first noticed). For this reason, we expand the type synonyms in
the eta-reduced types before doing any analysis.
-}

mkEqnHelp :: Maybe OverlapMode
          -> [TyVar]
          -> Class -> [Type]
          -> TyCon -> [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
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp overlap_mode :: Maybe OverlapMode
overlap_mode tvs :: [TyVar]
tvs cls :: Class
cls cls_tys :: ThetaType
cls_tys tycon :: TyCon
tycon tc_args :: ThetaType
tc_args deriv_ctxt :: DerivContext
deriv_ctxt deriv_strat :: Maybe (DerivStrategy GhcTc)
deriv_strat
  = do {      -- Find the instance of a data family
              -- Note [Looking up family instances for deriving]
         FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; let (rep_tc :: TyCon
rep_tc, rep_tc_args :: ThetaType
rep_tc_args, _co :: Coercion
_co) = FamInstEnvs -> TyCon -> ThetaType -> (TyCon, ThetaType, Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tycon ThetaType
tc_args
              -- If it's still a data family, the lookup failed; i.e no instance exists
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isDataFamilyTyCon TyCon
rep_tc)
              (SDoc -> TcRn ()
bale_out (String -> SDoc
text "No family instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> ThetaType -> SDoc
pprTypeApp TyCon
tycon ThetaType
tc_args)))
       ; 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
$
              SDoc -> TcRn ()
bale_out (String -> SDoc
text "Cannot derive instances in hs-boot files"
                    SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text "Write an instance declaration instead")

       ; let deriv_env :: DerivEnv
deriv_env = DerivEnv :: Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> TyCon
-> ThetaType
-> TyCon
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> DerivEnv
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_cls_tys :: ThetaType
denv_cls_tys      = ThetaType
cls_tys
                         , denv_tc :: TyCon
denv_tc           = TyCon
tycon
                         , denv_tc_args :: ThetaType
denv_tc_args      = ThetaType
tc_args
                         , denv_rep_tc :: TyCon
denv_rep_tc       = TyCon
rep_tc
                         , denv_rep_tc_args :: ThetaType
denv_rep_tc_args  = ThetaType
rep_tc_args
                         , denv_ctxt :: DerivContext
denv_ctxt         = DerivContext
deriv_ctxt
                         , denv_strat :: Maybe (DerivStrategy GhcTc)
denv_strat        = Maybe (DerivStrategy GhcTc)
deriv_strat }
       ; (ReaderT DerivEnv TcRn EarlyDerivSpec
 -> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec)
-> DerivEnv
-> ReaderT DerivEnv TcRn EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT DerivEnv TcRn EarlyDerivSpec
-> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DerivEnv
deriv_env (ReaderT DerivEnv TcRn EarlyDerivSpec
 -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
         if TyCon -> Bool
isNewTyCon TyCon
rep_tc then ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn else ReaderT DerivEnv TcRn EarlyDerivSpec
mkDataTypeEqn }
  where
     bale_out :: SDoc -> TcRn ()
bale_out msg :: SDoc
msg = SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc (Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
False Class
cls ThetaType
cls_tys
                      (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tycon ThetaType
tc_args) Maybe (DerivStrategy GhcTc)
deriv_strat SDoc
msg)

{-
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 familes 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 FamInstEnv

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

-- | Derive an instance for a data type (i.e., non-newtype).
mkDataTypeEqn :: DerivM EarlyDerivSpec
mkDataTypeEqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mkDataTypeEqn
  = do Maybe (DerivStrategy GhcTc)
mb_strat <- (DerivEnv -> Maybe (DerivStrategy GhcTc))
-> ReaderT DerivEnv TcRn (Maybe (DerivStrategy GhcTc))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat
       let bale_out :: SDoc -> ReaderT DerivEnv TcRn b
bale_out msg :: SDoc
msg = do SDoc
err <- Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
False SDoc
msg
                             IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b)
-> IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall a b. (a -> b) -> a -> b
$ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. SDoc -> TcM a
failWithTc SDoc
err
       case Maybe (DerivStrategy GhcTc)
mb_strat of
         Just StockStrategy    -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock    DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out
         Just AnyclassStrategy -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out
         Just (ViaStrategy ty :: XViaStrategy GhcTc
ty) -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via Type
XViaStrategy GhcTc
ty
         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
         Just NewtypeStrategy  -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out SDoc
gndNonNewtypeErr
         -- Lacking a user-requested deriving strategy, we will try to pick
         -- between the stock or anyclass strategies
         Nothing -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_mechanism DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. SDoc -> ReaderT DerivEnv TcRn b
bale_out

-- Derive an instance by way of an originative deriving strategy
-- (stock or anyclass).
--
-- See Note [Deriving strategies]
mk_originative_eqn
  :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or
                        -- DerivSpecAnyclass
  -> DerivM EarlyDerivSpec
mk_originative_eqn :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn 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_tc :: DerivEnv -> TyCon
denv_tc           = TyCon
tc
                , denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args      = ThetaType
tc_args
                , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc       = TyCon
rep_tc
                , denv_cls :: DerivEnv -> Class
denv_cls          = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys      = ThetaType
cls_tys
                , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt         = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       let inst_ty :: Type
inst_ty  = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args
           inst_tys :: ThetaType
inst_tys = ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]
       DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism
       SrcSpan
loc       <- TcRn SrcSpan -> ReaderT DerivEnv TcRn SrcSpan
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 (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 -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName' Class
cls TyCon
tc
       case DerivContext
deriv_ctxt of
        InferContext wildcard :: Maybe SrcSpan
wildcard ->
          do { (inferred_constraints :: [ThetaOrigin]
inferred_constraints, tvs' :: [TyVar]
tvs', inst_tys' :: ThetaType
inst_tys')
                 <- DerivSpecMechanism -> DerivM ([ThetaOrigin], [TyVar], ThetaType)
inferConstraints DerivSpecMechanism
mechanism
             ; EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 [ThetaOrigin] -> EarlyDerivSpec
InferTheta (DerivSpec [ThetaOrigin] -> EarlyDerivSpec)
-> DerivSpec [ThetaOrigin] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
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 :: ThetaType
ds_tys = ThetaType
inst_tys'
                   , ds_tc :: TyCon
ds_tc = TyCon
rep_tc
                   , ds_theta :: [ThetaOrigin]
ds_theta = [ThetaOrigin]
inferred_constraints
                   , 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 theta :: ThetaType
theta ->
            EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 ThetaType -> EarlyDerivSpec
GivenTheta (DerivSpec ThetaType -> EarlyDerivSpec)
-> DerivSpec ThetaType -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
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 :: ThetaType
ds_tys = ThetaType
inst_tys
                   , ds_tc :: TyCon
ds_tc = TyCon
rep_tc
                   , ds_theta :: ThetaType
ds_theta = ThetaType
theta
                   , 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 }

-- Derive an instance by way of a coerce-based deriving strategy
-- (newtype or via).
--
-- See Note [Deriving strategies]
mk_coerce_based_eqn
  :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype
                                  -- or DerivSpecVia
  -> Type -- The type to coerce
  -> DerivM EarlyDerivSpec
mk_coerce_based_eqn :: (Type -> DerivSpecMechanism)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_coerce_based_eqn mk_mechanism :: Type -> DerivSpecMechanism
mk_mechanism coerced_ty :: Type
coerced_ty
  = do DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
                , denv_tvs :: DerivEnv -> [TyVar]
denv_tvs          = [TyVar]
tvs
                , denv_tc :: DerivEnv -> TyCon
denv_tc           = TyCon
tycon
                , denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args      = ThetaType
tc_args
                , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc       = TyCon
rep_tycon
                , denv_cls :: DerivEnv -> Class
denv_cls          = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys      = ThetaType
cls_tys
                , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt         = DerivContext
deriv_ctxt } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
       Bool
sa_wildcard <- DerivM Bool
isStandaloneWildcardDeriv
       let -- The following functions are polymorphic over the representation
           -- type, since we might either give it the underlying type of a
           -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
           -- (for DerivingVia).
           rep_tys :: Type -> ThetaType
rep_tys ty :: Type
ty  = ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
ty]
           rep_pred :: Type -> Type
rep_pred ty :: Type
ty = Class -> ThetaType -> Type
mkClassPred Class
cls (Type -> ThetaType
rep_tys Type
ty)
           rep_pred_o :: Type -> PredOrigin
rep_pred_o ty :: Type
ty = CtOrigin -> TypeOrKind -> Type -> PredOrigin
mkPredOrigin CtOrigin
deriv_origin TypeOrKind
TypeLevel (Type -> Type
rep_pred Type
ty)
                   -- rep_pred is the representation dictionary, from where
                   -- we are going to get all the methods for the final
                   -- dictionary

           -- Next we figure out what superclass dictionaries to use
           -- See Note [Newtype deriving superclasses] above
           sc_preds   :: [PredOrigin]
           cls_tyvars :: [TyVar]
cls_tyvars = Class -> [TyVar]
classTyVars Class
cls
           inst_ty :: Type
inst_ty    = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tycon ThetaType
tc_args
           inst_tys :: ThetaType
inst_tys   = ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]
           sc_preds :: [PredOrigin]
sc_preds   = (Type -> PredOrigin) -> ThetaType -> [PredOrigin]
forall a b. (a -> b) -> [a] -> [b]
map (CtOrigin -> TypeOrKind -> Type -> PredOrigin
mkPredOrigin CtOrigin
deriv_origin TypeOrKind
TypeLevel) (ThetaType -> [PredOrigin]) -> ThetaType -> [PredOrigin]
forall a b. (a -> b) -> a -> b
$
                        HasCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTheta ([TyVar] -> ThetaType -> TCvSubst
HasDebugCallStack => [TyVar] -> ThetaType -> TCvSubst
zipTvSubst [TyVar]
cls_tyvars ThetaType
inst_tys) (ThetaType -> ThetaType) -> ThetaType -> ThetaType
forall a b. (a -> b) -> a -> b
$
                        Class -> ThetaType
classSCTheta Class
cls
           deriv_origin :: CtOrigin
deriv_origin = Bool -> CtOrigin
mkDerivOrigin Bool
sa_wildcard

           -- Next we collect constraints for the class methods
           -- If there are no methods, we don't need any constraints
           -- Otherwise we need (C rep_ty), for the representation methods,
           -- and constraints to coerce each individual method
           meth_preds :: Type -> [PredOrigin]
           meths :: [TyVar]
meths = Class -> [TyVar]
classMethods Class
cls
           meth_preds :: Type -> [PredOrigin]
meth_preds ty :: Type
ty
             | [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
meths = [] -- No methods => no constraints
                               -- (Trac #12814)
             | Bool
otherwise = Type -> PredOrigin
rep_pred_o Type
ty PredOrigin -> [PredOrigin] -> [PredOrigin]
forall a. a -> [a] -> [a]
: Type -> [PredOrigin]
coercible_constraints Type
ty
           coercible_constraints :: Type -> [PredOrigin]
coercible_constraints ty :: Type
ty
             = [ CtOrigin -> TypeOrKind -> Type -> PredOrigin
mkPredOrigin (TyVar -> Type -> Type -> Bool -> CtOrigin
DerivOriginCoerce TyVar
meth Type
t1 Type
t2 Bool
sa_wildcard)
                              TypeOrKind
TypeLevel (Type -> Type -> Type
mkReprPrimEqPred Type
t1 Type
t2)
               | TyVar
meth <- [TyVar]
meths
               , let (Pair t1 :: Type
t1 t2 :: Type
t2) = Class -> [TyVar] -> ThetaType -> Type -> TyVar -> Pair Type
mkCoerceClassMethEqn Class
cls [TyVar]
tvs
                                            ThetaType
inst_tys Type
ty TyVar
meth ]

           all_thetas :: Type -> [ThetaOrigin]
           all_thetas :: Type -> [ThetaOrigin]
all_thetas ty :: Type
ty = [[PredOrigin] -> ThetaOrigin
mkThetaOriginFromPreds ([PredOrigin] -> ThetaOrigin) -> [PredOrigin] -> ThetaOrigin
forall a b. (a -> b) -> a -> b
$ Type -> [PredOrigin]
meth_preds Type
ty [PredOrigin] -> [PredOrigin] -> [PredOrigin]
forall a. [a] -> [a] -> [a]
++ [PredOrigin]
sc_preds]

           inferred_thetas :: [ThetaOrigin]
inferred_thetas = Type -> [ThetaOrigin]
all_thetas Type
coerced_ty
       TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> TcRn ()
traceTc "newtype deriving:" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> ThetaType
rep_tys Type
coerced_ty) SDoc -> SDoc -> SDoc
<+> [ThetaOrigin] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ThetaOrigin]
inferred_thetas
       let mechanism :: DerivSpecMechanism
mechanism = Type -> DerivSpecMechanism
mk_mechanism Type
coerced_ty
           bale_out :: SDoc -> DerivM ()
bale_out msg :: SDoc
msg = do SDoc
err <- DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
msg
                             TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc SDoc
err
       Class -> (SDoc -> DerivM ()) -> DerivM ()
atf_coerce_based_error_checks Class
cls SDoc -> DerivM ()
bale_out
       DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism
       Name
dfun_name <- IOEnv (Env TcGblEnv TcLclEnv) Name -> ReaderT DerivEnv TcRn Name
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 -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName' Class
cls TyCon
tycon
       SrcSpan
loc       <- TcRn SrcSpan -> ReaderT DerivEnv TcRn SrcSpan
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn SrcSpan
getSrcSpanM
       case DerivContext
deriv_ctxt of
        SupplyContext theta :: ThetaType
theta -> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 ThetaType -> EarlyDerivSpec
GivenTheta (DerivSpec ThetaType -> EarlyDerivSpec)
-> DerivSpec ThetaType -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
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 :: ThetaType
ds_tys = ThetaType
inst_tys
            , ds_tc :: TyCon
ds_tc = TyCon
rep_tycon
            , ds_theta :: ThetaType
ds_theta = ThetaType
theta
            , 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 }
        InferContext wildcard :: Maybe SrcSpan
wildcard -> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
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 [ThetaOrigin] -> EarlyDerivSpec
InferTheta (DerivSpec [ThetaOrigin] -> EarlyDerivSpec)
-> DerivSpec [ThetaOrigin] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> TyCon
-> Maybe OverlapMode
-> Maybe SrcSpan
-> DerivSpecMechanism
-> DerivSpec theta
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 :: ThetaType
ds_tys = ThetaType
inst_tys
            , ds_tc :: TyCon
ds_tc = TyCon
rep_tycon
            , ds_theta :: [ThetaOrigin]
ds_theta = [ThetaOrigin]
inferred_thetas
            , 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 }

-- Ensure that a class's associated type variables are suitable for
-- GeneralizedNewtypeDeriving or DerivingVia.
--
-- See Note [GND and associated type families]
atf_coerce_based_error_checks
  :: Class
  -> (SDoc -> DerivM ())
  -> DerivM ()
atf_coerce_based_error_checks :: Class -> (SDoc -> DerivM ()) -> DerivM ()
atf_coerce_based_error_checks cls :: Class
cls bale_out :: SDoc -> DerivM ()
bale_out
  = let 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

        (adf_tcs :: [TyCon]
adf_tcs, atf_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 (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 (\tc :: 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 (\tc :: 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 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 = ASSERT( notNull cls_tyvars )
                      [TyVar] -> TyVar
forall a. [a] -> a
last [TyVar]
cls_tyvars

        cant_derive_err :: SDoc
cant_derive_err
           = [SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppUnless Bool
no_adfs SDoc
adfs_msg
                  , SDoc -> (TyCon -> SDoc) -> Maybe TyCon -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty TyCon -> SDoc
at_without_last_cls_tv_msg
                          Maybe TyCon
at_without_last_cls_tv
                  , SDoc -> (TyCon -> SDoc) -> Maybe TyCon -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty TyCon -> SDoc
at_last_cls_tv_in_kinds_msg
                          Maybe TyCon
at_last_cls_tv_in_kinds
                  ]
        adfs_msg :: SDoc
adfs_msg  = String -> SDoc
text "the class has associated data types"
        at_without_last_cls_tv_msg :: TyCon -> SDoc
at_without_last_cls_tv_msg at_tc :: TyCon
at_tc = SDoc -> Int -> SDoc -> SDoc
hang
          (String -> SDoc
text "the associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
at_tc)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not parameterized over the last type variable")
          2 (String -> SDoc
text "of the class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls))
        at_last_cls_tv_in_kinds_msg :: TyCon -> SDoc
at_last_cls_tv_in_kinds_msg at_tc :: TyCon
at_tc = SDoc -> Int -> SDoc -> SDoc
hang
          (String -> SDoc
text "the associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
at_tc)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "contains the last type variable")
         2 (String -> SDoc
text "of the class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "in a kind, which is not (yet) allowed")
    in Bool -> DerivM () -> DerivM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ats_look_sensible (DerivM () -> DerivM ()) -> DerivM () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> DerivM ()
bale_out SDoc
cant_derive_err

mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
             -> (SDoc -> DerivM EarlyDerivSpec)
             -> DerivM EarlyDerivSpec
mk_eqn_stock :: (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock go_for_it :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it bale_out :: SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
  = do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc      = TyCon
tc
                , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc  = TyCon
rep_tc
                , denv_cls :: DerivEnv -> Class
denv_cls     = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
                , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt    = DerivContext
deriv_ctxt } <- 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
       case DynFlags
-> DerivContext
-> Class
-> ThetaType
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls ThetaType
cls_tys
                                           TyCon
tc TyCon
rep_tc of
         CanDeriveStock gen_fn :: SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ (SrcSpan
 -> TyCon
 -> ThetaType
 -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> DerivSpecMechanism
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn
         StockClassError msg :: SDoc
msg   -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg
         _                     -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (Class -> SDoc
nonStdErr Class
cls)

mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
                -> (SDoc -> DerivM EarlyDerivSpec)
                -> DerivM EarlyDerivSpec
mk_eqn_anyclass :: (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass go_for_it :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it bale_out :: SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
  = do DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       case DynFlags -> Validity
canDeriveAnyClass DynFlags
dflags of
         IsValid      -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it DerivSpecMechanism
DerivSpecAnyClass
         NotValid msg :: SDoc
msg -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg

mk_eqn_newtype :: Type -- The newtype's representation type
               -> DerivM EarlyDerivSpec
mk_eqn_newtype :: Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype = (Type -> DerivSpecMechanism)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_coerce_based_eqn Type -> DerivSpecMechanism
DerivSpecNewtype

mk_eqn_via :: Type -- The @via@ type
           -> DerivM EarlyDerivSpec
mk_eqn_via :: Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via = (Type -> DerivSpecMechanism)
-> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_coerce_based_eqn Type -> DerivSpecMechanism
DerivSpecVia

mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
                    -> (SDoc -> DerivM EarlyDerivSpec)
                    -> DerivM EarlyDerivSpec
mk_eqn_no_mechanism :: (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_mechanism go_for_it :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it bale_out :: SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
  = do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc      = TyCon
tc
                , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc  = TyCon
rep_tc
                , denv_cls :: DerivEnv -> Class
denv_cls     = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
                , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt    = DerivContext
deriv_ctxt } <- 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

           -- See Note [Deriving instances for classes themselves]
       let dac_error :: SDoc -> SDoc
dac_error msg :: SDoc
msg
             | TyCon -> Bool
isClassTyCon TyCon
rep_tc
             = SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is a type class,"
                               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "and can only have a derived instance"
                               SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text "if DeriveAnyClass is enabled"
             | Bool
otherwise
             = Class -> SDoc
nonStdErr Class
cls SDoc -> SDoc -> SDoc
$$ SDoc
msg

       case DynFlags
-> DerivContext
-> Class
-> ThetaType
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls ThetaType
cls_tys
                                           TyCon
tc TyCon
rep_tc of
           -- NB: pass the *representation* tycon to
           -- checkOriginativeSideConditions
           NonDerivableClass   msg :: SDoc
msg -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc -> SDoc
dac_error SDoc
msg)
           StockClassError msg :: SDoc
msg     -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg
           CanDeriveStock gen_fn :: SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn   -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ (SrcSpan
 -> TyCon
 -> ThetaType
 -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> DerivSpecMechanism
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn
           CanDeriveAnyClass       -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
go_for_it DerivSpecMechanism
DerivSpecAnyClass

{-
************************************************************************
*                                                                      *
            GeneralizedNewtypeDeriving and DerivingVia
*                                                                      *
************************************************************************
-}

-- | Derive an instance for a newtype.
mkNewTypeEqn :: DerivM EarlyDerivSpec
mkNewTypeEqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
  = do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc           = TyCon
tycon
                , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc       = TyCon
rep_tycon
                , denv_rep_tc_args :: DerivEnv -> ThetaType
denv_rep_tc_args  = ThetaType
rep_tc_args
                , denv_cls :: DerivEnv -> Class
denv_cls          = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys      = ThetaType
cls_tys
                , denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt         = DerivContext
deriv_ctxt
                , 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
       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 :: SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out        = Bool -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall b. Bool -> SDoc -> ReaderT DerivEnv TcRn b
bale_out' Bool
newtype_deriving
           bale_out' :: Bool -> SDoc -> ReaderT DerivEnv TcRn b
bale_out' b :: Bool
b msg :: SDoc
msg = do SDoc
err <- Bool -> SDoc -> DerivM SDoc
derivingThingErrM Bool
b SDoc
msg
                                IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b)
-> IOEnv (Env TcGblEnv TcLclEnv) b -> ReaderT DerivEnv TcRn b
forall a b. (a -> b) -> a -> b
$ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. SDoc -> TcM a
failWithTc SDoc
err

           non_std :: SDoc
non_std     = Class -> SDoc
nonStdErr Class
cls
           suggest_gnd :: SDoc
suggest_gnd = String -> SDoc
text "Try GeneralizedNewtypeDeriving for GHC's"
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "newtype-deriving extension"

           -- 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 -> ThetaType -> Type
newTyConInstRhs TyCon
rep_tycon ThetaType
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 = ThetaType
rep_tc_args ThetaType -> 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.

           cant_derive_err :: SDoc
cant_derive_err = Bool -> SDoc -> SDoc
ppUnless Bool
eta_ok  SDoc
eta_msg
           eta_msg :: SDoc
eta_msg = String -> SDoc
text "cannot eta-reduce the representation type enough"

       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
       case Maybe (DerivStrategy GhcTc)
mb_strat of
         Just StockStrategy    -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock    DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
         Just AnyclassStrategy -> (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> (SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out
         Just NewtypeStrategy  ->
           -- 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 Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype Type
rep_inst_ty
             else SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc
cant_derive_err SDoc -> SDoc -> SDoc
$$
                            if Bool
newtype_deriving then SDoc
empty else SDoc
suggest_gnd)
         Just (ViaStrategy via_ty :: XViaStrategy GhcTc
via_ty) ->
           -- NB: For DerivingVia, we don't need to any eta-reduction checking,
           -- since the @via@ type is already "eta-reduced".
           Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via Type
XViaStrategy GhcTc
via_ty
         Nothing
           | 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)
          -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype Type
rep_inst_ty
           | Bool
otherwise
          -> case DynFlags
-> DerivContext
-> Class
-> ThetaType
-> TyCon
-> TyCon
-> OriginativeDerivStatus
checkOriginativeSideConditions DynFlags
dflags DerivContext
deriv_ctxt Class
cls ThetaType
cls_tys
                                                 TyCon
tycon TyCon
rep_tycon of
               StockClassError msg :: SDoc
msg
                 -- 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 Trac #10598.
                 | Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool
newtype_deriving
                -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype 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
                -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
suggest_gnd)
                 | Bool
otherwise
                -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
msg

               -- Must use newtype deriving or DeriveAnyClass
               NonDerivableClass _msg :: SDoc
_msg
                 -- Too hard, even with newtype deriving
                 | Bool
newtype_deriving           -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out SDoc
cant_derive_err
                 -- Try newtype deriving!
                 -- Here we suggest GeneralizedNewtypeDeriving even in cases
                 -- where it may not be applicable. See Trac #9600.
                 | Bool
otherwise                  -> SDoc -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (SDoc
non_std SDoc -> SDoc -> SDoc
$$ SDoc
suggest_gnd)

               -- DeriveAnyClass
               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 -> DerivM () -> DerivM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool
deriveAnyClass) (DerivM () -> DerivM ()) -> DerivM () -> DerivM ()
forall a b. (a -> b) -> a -> b
$
                   TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
                     [ String -> SDoc
text "Both DeriveAnyClass and"
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "GeneralizedNewtypeDeriving are enabled"
                     , String -> SDoc
text "Defaulting to the DeriveAnyClass strategy"
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "for instantiating" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
                     , String -> SDoc
text "Use DerivingStrategies to pick"
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "a different strategy"
                      ]
                 DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn DerivSpecMechanism
DerivSpecAnyClass
               -- CanDeriveStock
               CanDeriveStock gen_fn :: SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_originative_eqn (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
                                        (SrcSpan
 -> TyCon
 -> ThetaType
 -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> DerivSpecMechanism
DerivSpecStock SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn

{-
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 famillies.

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.

************************************************************************
*                                                                      *
\subsection[TcDeriv-normal-binds]{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 paired with the
--   *representation* tycon for that instance,
-- plus any auxiliary bindings required
--
-- Representation tycons differ from the tycon in the instance signature in
-- case of instances for indexed families.
--
genInst :: DerivSpec theta
        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-- We must use continuation-returning style here to get the order in which we
-- typecheck family instances and derived instances right.
-- See Note [Staging of tcDeriving]
genInst :: DerivSpec theta
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
genInst spec :: DerivSpec theta
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tvs, ds_tc :: forall theta. DerivSpec theta -> TyCon
ds_tc = TyCon
rep_tycon
                 , ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism, ds_tys :: forall theta. DerivSpec theta -> ThetaType
ds_tys = ThetaType
tys
                 , 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 })
  = do (meth_binds :: Bag (LHsBind GhcPs)
meth_binds, deriv_stuff :: BagDerivStuff
deriv_stuff, unusedNames :: [Name]
unusedNames)
         <- TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall a. TcRn a -> TcRn a
set_span_and_ctxt (TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
 -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name]))
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall a b. (a -> b) -> a -> b
$
            DerivSpecMechanism
-> SrcSpan
-> Class
-> TyCon
-> ThetaType
-> [TyVar]
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
genDerivStuff DerivSpecMechanism
mechanism SrcSpan
loc Class
clas TyCon
rep_tycon ThetaType
tys [TyVar]
tvs
       let mk_inst_info :: ThetaType -> TcM (InstInfo GhcPs)
mk_inst_info theta :: ThetaType
theta = TcM (InstInfo GhcPs) -> TcM (InstInfo GhcPs)
forall a. TcRn a -> TcRn a
set_span_and_ctxt (TcM (InstInfo GhcPs) -> TcM (InstInfo GhcPs))
-> TcM (InstInfo GhcPs) -> TcM (InstInfo GhcPs)
forall a b. (a -> b) -> a -> b
$ do
             ClsInst
inst_spec <- ThetaType -> DerivSpec theta -> TcM ClsInst
forall theta. ThetaType -> DerivSpec theta -> TcM ClsInst
newDerivClsInst ThetaType
theta DerivSpec theta
spec
             Class
-> ClsInst
-> ThetaType
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
inst_spec ThetaType
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
             String -> SDoc -> TcRn ()
traceTc "newder" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
inst_spec)
             InstInfo GhcPs -> TcM (InstInfo GhcPs)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs -> TcM (InstInfo GhcPs))
-> InstInfo GhcPs -> TcM (InstInfo GhcPs)
forall a b. (a -> b) -> a -> b
$ InstInfo :: forall a. ClsInst -> InstBindings a -> InstInfo a
InstInfo
                       { iSpec :: ClsInst
iSpec   = ClsInst
inst_spec
                       , iBinds :: InstBindings GhcPs
iBinds  = InstBindings :: forall a.
[Name]
-> LHsBinds a -> [LSig a] -> [Extension] -> Bool -> InstBindings a
InstBindings
                                     { ib_binds :: Bag (LHsBind GhcPs)
ib_binds = Bag (LHsBind 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]
tvs
                                     , ib_pragmas :: [LSig GhcPs]
ib_pragmas = []
                                     , ib_extensions :: [Extension]
ib_extensions = [Extension]
extensions
                                     , ib_derived :: Bool
ib_derived = Bool
True } }
       (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (ThetaType -> TcM (InstInfo GhcPs)
mk_inst_info, BagDerivStuff
deriv_stuff, [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
        -- See Note [Newtype-deriving instances] in TcGenDeriv
      = [Extension
LangExt.ImpredicativeTypes, Extension
LangExt.RankNTypes]
      | Bool
otherwise
      = []

    set_span_and_ctxt :: TcM a -> TcM a
    set_span_and_ctxt :: TcM a -> TcM a
set_span_and_ctxt = SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM a -> TcM a) -> (TcM a -> TcM a) -> TcM a -> TcM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Class -> ThetaType -> SDoc
instDeclCtxt3 Class
clas ThetaType
tys)

doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 mechanism :: DerivSpecMechanism
mechanism = do
    DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc      = TyCon
tc
             , denv_rep_tc :: DerivEnv -> TyCon
denv_rep_tc  = TyCon
rep_tc } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Bool
standalone <- DerivM Bool
isStandaloneDeriv
    let anyclass_strategy :: Bool
anyclass_strategy = DerivSpecMechanism -> Bool
isDerivSpecAnyClass DerivSpecMechanism
mechanism
        via_strategy :: Bool
via_strategy      = DerivSpecMechanism -> Bool
isDerivSpecVia DerivSpecMechanism
mechanism
        bale_out :: SDoc -> DerivM ()
bale_out msg :: SDoc
msg = do SDoc
err <- DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism DerivSpecMechanism
mechanism SDoc
msg
                          TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWithTc SDoc
err

    -- For standalone deriving, check that all the data constructors are in
    -- scope...
    GlobalRdrEnv
rdr_env <- IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> ReaderT DerivEnv TcRn GlobalRdrEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv (Env TcGblEnv TcLclEnv) 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 (Name -> Bool
isWiredInName (TyCon -> Name
tyConName 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 dc :: Name
dc  = Maybe GlobalRdrElt -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc)

    TcRn () -> DerivM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> DerivM ()) -> TcRn () -> DerivM ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> TyCon -> TcRn ()
addUsedDataCons GlobalRdrEnv
rdr_env TyCon
rep_tc

    -- ...however, we don't perform this check if we're using DeriveAnyClass,
    -- since it doesn't generate any code that requires use of a data
    -- constructor. Nor do we perform this check with @deriving via@, as it
    -- doesn't explicitly require the constructors to be in scope.
    Bool -> DerivM () -> DerivM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
anyclass_strategy Bool -> Bool -> Bool
|| Bool
via_strategy
            Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
standalone Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
hidden_data_cons) (DerivM () -> DerivM ()) -> DerivM () -> DerivM ()
forall a b. (a -> b) -> a -> b
$
           SDoc -> DerivM ()
bale_out (SDoc -> DerivM ()) -> SDoc -> DerivM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
derivingHiddenErr TyCon
tc

doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
                        -> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 :: Class
-> ClsInst
-> ThetaType
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 clas :: Class
clas clas_inst :: ClsInst
clas_inst theta :: ThetaType
theta wildcard :: Maybe SrcSpan
wildcard mechanism :: DerivSpecMechanism
mechanism
  = do { String -> SDoc -> TcRn ()
traceTc "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
           Nothing -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           Just span :: 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
             Bool -> SDoc -> TcRn ()
checkTc Bool
xpartial_sigs (SDoc -> Int -> SDoc -> SDoc
hang SDoc
partial_sig_msg 2 SDoc
pts_suggestion)
             WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnPartialTypeSignatures)
                    Bool
wpartial_sigs SDoc
partial_sig_msg

         -- 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 (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 -> SDoc -> TcRn ()
failIfTc (DynFlags -> Bool
safeLanguageOn DynFlags
dflags) SDoc
gen_inst_err
            ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeInferOn DynFlags
dflags) (WarningMessages -> TcRn ()
recordUnsafeInfer WarningMessages
forall a. Bag a
emptyBag) } }
  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

    partial_sig_msg :: SDoc
partial_sig_msg = String -> SDoc
text "Found type wildcard" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char '_')
                  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "standing for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ThetaType -> SDoc
pprTheta ThetaType
theta)

    pts_suggestion :: SDoc
pts_suggestion
      = String -> SDoc
text "To use the inferred type, enable PartialTypeSignatures"

    gen_inst_err :: SDoc
gen_inst_err = String -> SDoc
text "Generic instances can only be derived in"
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "Safe Haskell using the stock strategy."

genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
              -> TyCon -> [Type] -> [TyVar]
              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
genDerivStuff :: DerivSpecMechanism
-> SrcSpan
-> Class
-> TyCon
-> ThetaType
-> [TyVar]
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
genDerivStuff mechanism :: DerivSpecMechanism
mechanism loc :: SrcSpan
loc clas :: Class
clas tycon :: TyCon
tycon inst_tys :: ThetaType
inst_tys tyvars :: [TyVar]
tyvars
  = case DerivSpecMechanism
mechanism of
      -- See Note [Bindings for Generalised Newtype Deriving]
      DerivSpecNewtype rhs_ty :: Type
rhs_ty -> Type -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_newtype_or_via Type
rhs_ty

      -- Try a stock deriver
      DerivSpecStock gen_fn :: SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn -> SrcSpan
-> TyCon
-> ThetaType
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_fn SrcSpan
loc TyCon
tycon ThetaType
inst_tys

      -- Try DeriveAnyClass
      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] -> ThetaType -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ThetaType
inst_tys)
            mini_subst :: TCvSubst
mini_subst = InScopeSet -> VarEnv Type -> TCvSubst
mkTvSubst (VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [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.
          ASSERT2( isValid (canDeriveAnyClass dflags)
                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )
          (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)
mapM (SrcSpan
-> TCvSubst
-> Uses
-> ClassATItem
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
tcATDefault SrcSpan
loc TCvSubst
mini_subst Uses
emptyNameSet)
               (Class -> [ClassATItem]
classATItems Class
clas)
        (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bag (LHsBind GhcPs)
forall a. Bag a
emptyBag -- No method bindings are needed...
               , [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ((FamInst -> DerivStuff) -> [FamInst] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> DerivStuff
DerivFamInst ([[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
tyfam_insts))
               -- ...but we may need to generate binding for associated type
               -- family default instances.
               -- See Note [DeriveAnyClass and default family instances]
               , [] )

      -- Try DerivingVia
      DerivSpecVia via_ty :: Type
via_ty -> Type -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_newtype_or_via Type
via_ty
  where
    gen_newtype_or_via :: Type -> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
gen_newtype_or_via ty :: Type
ty = do
      (binds :: Bag (LHsBind GhcPs)
binds, faminsts :: BagDerivStuff
faminsts) <- SrcSpan
-> Class
-> [TyVar]
-> ThetaType
-> Type
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff)
gen_Newtype_binds SrcSpan
loc Class
clas [TyVar]
tyvars ThetaType
inst_tys Type
ty
      (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
-> TcM (Bag (LHsBind GhcPs), BagDerivStuff, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (LHsBind GhcPs)
binds, BagDerivStuff
faminsts, Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
unusedConName)

    unusedConName :: Maybe Name
    unusedConName :: Maybe Name
unusedConName
      | DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism
        -- See Note [Newtype deriving and unused constructors]
      = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ DataCon -> Name
forall a. NamedThing a => a -> Name
getName (DataCon -> Name) -> DataCon -> Name
forall a b. (a -> b) -> a -> b
$ [DataCon] -> DataCon
forall a. [a] -> a
head ([DataCon] -> DataCon) -> [DataCon] -> DataCon
forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
tyConDataCons TyCon
tycon
      | Bool
otherwise
      = Maybe Name
forall a. Maybe a
Nothing

{-
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 superclasse 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 TcClassDcl (which is also used in TcInstDcls 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 Trac ticket (#10598) or the associated wiki page:
https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies

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. 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`).

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://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
("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 TcDeriv 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).

************************************************************************
*                                                                      *
\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
*                                                                      *
************************************************************************
-}

nonUnaryErr :: LHsSigType GhcRn -> SDoc
nonUnaryErr :: LHsSigType GhcRn -> SDoc
nonUnaryErr ct :: LHsSigType GhcRn
ct = SDoc -> SDoc
quotes (LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
ct)
  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not a unary constraint, as expected by a deriving clause"

nonStdErr :: Class -> SDoc
nonStdErr :: Class -> SDoc
nonStdErr cls :: Class
cls =
      SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not a stock derivable class (Eq, Show, etc.)"

gndNonNewtypeErr :: SDoc
gndNonNewtypeErr :: SDoc
gndNonNewtypeErr =
  String -> SDoc
text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"

derivingNullaryErr :: MsgDoc
derivingNullaryErr :: SDoc
derivingNullaryErr = String -> SDoc
text "Cannot derive instances for nullary classes"

derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc
derivingKindErr :: TyCon -> Class -> ThetaType -> Type -> Bool -> SDoc
derivingKindErr tc :: TyCon
tc cls :: Class
cls cls_tys :: ThetaType
cls_tys cls_kind :: Type
cls_kind enough_args :: Bool
enough_args
  = [SDoc] -> SDoc
sep [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Cannot derive well-kinded instance of form"
                      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> ThetaType -> SDoc
pprClassPred Class
cls ThetaType
cls_tys
                                    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "...")))
               2 SDoc
gen1_suggestion
        , Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "expects an argument of kind"
                      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
cls_kind))
        ]
  where
    gen1_suggestion :: SDoc
gen1_suggestion | Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
gen1ClassKey Bool -> Bool -> Bool
&& Bool
enough_args
                    = String -> SDoc
text "(Perhaps you intended to use PolyKinds)"
                    | Bool
otherwise = SDoc
Outputable.empty

derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc
derivingViaKindErr :: Class -> Type -> Type -> Type -> SDoc
derivingViaKindErr cls :: Class
cls cls_kind :: Type
cls_kind via_ty :: Type
via_ty via_kind :: Type
via_kind
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Cannot derive instance via" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
via_ty))
       2 (String -> SDoc
text "Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "expects an argument of kind"
               SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
cls_kind) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char ','
      SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text "but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
via_ty)
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
via_kind))

derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
derivingEtaErr :: Class -> ThetaType -> Type -> SDoc
derivingEtaErr cls :: Class
cls cls_tys :: ThetaType
cls_tys inst_ty :: Type
inst_ty
  = [SDoc] -> SDoc
sep [String -> SDoc
text "Cannot eta-reduce to an instance of form",
         Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "instance (...) =>"
                SDoc -> SDoc -> SDoc
<+> Class -> ThetaType -> SDoc
pprClassPred Class
cls (ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]))]

derivingThingErr :: Bool -> Class -> [Type] -> Type
                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc
derivingThingErr :: Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr newtype_deriving :: Bool
newtype_deriving cls :: Class
cls cls_tys :: ThetaType
cls_tys inst_ty :: Type
inst_ty mb_strat :: Maybe (DerivStrategy GhcTc)
mb_strat why :: SDoc
why
  = Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' Bool
newtype_deriving Class
cls ThetaType
cls_tys Type
inst_ty Maybe (DerivStrategy GhcTc)
mb_strat
                      (SDoc
-> (DerivStrategy GhcTc -> SDoc)
-> Maybe (DerivStrategy GhcTc)
-> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty DerivStrategy GhcTc -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName Maybe (DerivStrategy GhcTc)
mb_strat) SDoc
why

derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
derivingThingErrM :: Bool -> SDoc -> DerivM SDoc
derivingThingErrM newtype_deriving :: Bool
newtype_deriving why :: SDoc
why
  = do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc      = TyCon
tc
                , denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args = ThetaType
tc_args
                , denv_cls :: DerivEnv -> Class
denv_cls     = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
                , 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
       SDoc -> DerivM SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> DerivM SDoc) -> SDoc -> DerivM SDoc
forall a b. (a -> b) -> a -> b
$ Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
derivingThingErr Bool
newtype_deriving Class
cls ThetaType
cls_tys
                               (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args) Maybe (DerivStrategy GhcTc)
mb_strat SDoc
why

derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc
derivingThingErrMechanism mechanism :: DerivSpecMechanism
mechanism why :: SDoc
why
  = do DerivEnv { denv_tc :: DerivEnv -> TyCon
denv_tc      = TyCon
tc
                , denv_tc_args :: DerivEnv -> ThetaType
denv_tc_args = ThetaType
tc_args
                , denv_cls :: DerivEnv -> Class
denv_cls     = Class
cls
                , denv_cls_tys :: DerivEnv -> ThetaType
denv_cls_tys = ThetaType
cls_tys
                , 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
       SDoc -> DerivM SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> DerivM SDoc) -> SDoc -> DerivM SDoc
forall a b. (a -> b) -> a -> b
$ Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' (DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism) Class
cls ThetaType
cls_tys
                (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args) Maybe (DerivStrategy GhcTc)
mb_strat
                (DerivStrategy GhcTc -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName (DerivStrategy GhcTc -> SDoc) -> DerivStrategy GhcTc -> SDoc
forall a b. (a -> b) -> a -> b
$ DerivSpecMechanism -> DerivStrategy GhcTc
derivSpecMechanismToStrategy DerivSpecMechanism
mechanism)
                SDoc
why

derivingThingErr' :: Bool -> Class -> [Type] -> Type
                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc
derivingThingErr' :: Bool
-> Class
-> ThetaType
-> Type
-> Maybe (DerivStrategy GhcTc)
-> SDoc
-> SDoc
-> SDoc
derivingThingErr' newtype_deriving :: Bool
newtype_deriving cls :: Class
cls cls_tys :: ThetaType
cls_tys inst_ty :: Type
inst_ty mb_strat :: Maybe (DerivStrategy GhcTc)
mb_strat strat_msg :: SDoc
strat_msg why :: SDoc
why
  = [SDoc] -> SDoc
sep [(SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Can't make a derived instance of")
             2 (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred) SDoc -> SDoc -> SDoc
<+> SDoc
via_mechanism)
          SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 2 SDoc
extra) SDoc -> SDoc -> SDoc
<> SDoc
colon,
         Int -> SDoc -> SDoc
nest 2 SDoc
why]
  where
    strat_used :: Bool
strat_used = Maybe (DerivStrategy GhcTc) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (DerivStrategy GhcTc)
mb_strat
    extra :: SDoc
extra | Bool -> Bool
not Bool
strat_used, Bool
newtype_deriving
          = String -> SDoc
text "(even with cunning GeneralizedNewtypeDeriving)"
          | Bool
otherwise = SDoc
empty
    pred :: Type
pred = Class -> ThetaType -> Type
mkClassPred Class
cls (ThetaType
cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty])
    via_mechanism :: SDoc
via_mechanism | Bool
strat_used
                  = String -> SDoc
text "with the" SDoc -> SDoc -> SDoc
<+> SDoc
strat_msg SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "strategy"
                  | Bool
otherwise
                  = SDoc
empty

derivingHiddenErr :: TyCon -> SDoc
derivingHiddenErr :: TyCon -> SDoc
derivingHiddenErr tc :: TyCon
tc
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The data constructors of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "are not all in scope"))
       2 (String -> SDoc
text "so you cannot derive an instance for it")

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