{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where
import GHC.Prelude
import GHC.Hs
import GHC.Driver.Session
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Deriv.Infer
import GHC.Tc.Deriv.Utils
import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
import GHC.Tc.Utils.Env
import GHC.Tc.Deriv.Generate
import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead )
import GHC.Core.InstEnv
import GHC.Tc.Utils.Instantiate
import GHC.Core.FamInstEnv
import GHC.Tc.Gen.HsType
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars )
import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Module ( addTcgDUs )
import GHC.Rename.Utils
import GHC.Core.Unify( tcUnifyTy )
import GHC.Core.Class
import GHC.Core.Type
import GHC.Utils.Error
import GHC.Core.DataCon
import GHC.Data.Maybe
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Set as NameSet
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Data.Bag
import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List (partition, find)
data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)
| GivenTheta (DerivSpec ThetaType)
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta DerivSpec ThetaSpec
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec ThetaSpec]
is, [DerivSpec ThetaType]
gs) -> (DerivSpec ThetaSpec
spec DerivSpec ThetaSpec
-> [DerivSpec ThetaSpec] -> [DerivSpec ThetaSpec]
forall a. a -> [a] -> [a]
: [DerivSpec ThetaSpec]
is, [DerivSpec ThetaType]
gs)
splitEarlyDerivSpec (GivenTheta DerivSpec ThetaType
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec ThetaSpec]
is, [DerivSpec ThetaType]
gs) -> ([DerivSpec ThetaSpec]
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 DerivSpec ThetaSpec
spec) = DerivSpec ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec ThetaSpec
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(Infer)"
ppr (GivenTheta DerivSpec ThetaType
spec) = DerivSpec ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec ThetaType
spec SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(Given)"
data DerivInfo = DerivInfo { DerivInfo -> TyCon
di_rep_tc :: TyCon
, DerivInfo -> [(Name, TyVar)]
di_scoped_tvs :: ![(Name,TyVar)]
, DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses :: [LHsDerivingClause GhcRn]
, DerivInfo -> SDoc
di_ctxt :: SDoc
}
tcDeriving :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
= TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (do { TcGblEnv
g <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall (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 {
[EarlyDerivSpec]
early_specs <- [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
; String -> SDoc -> TcRn ()
traceTc String
"tcDeriving" ([EarlyDerivSpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EarlyDerivSpec]
early_specs)
; let ([DerivSpec ThetaSpec]
infer_specs, [DerivSpec ThetaType]
given_specs) = [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec [EarlyDerivSpec]
early_specs
; [FamInst]
famInsts1 <- (DerivSpec ThetaType -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [DerivSpec ThetaType] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM DerivSpec ThetaType -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta.
DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts [DerivSpec ThetaType]
given_specs
; [FamInst]
famInsts2 <- (DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [DerivSpec ThetaSpec] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM DerivSpec ThetaSpec -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta.
DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts [DerivSpec ThetaSpec]
infer_specs
; let famInsts :: [FamInst]
famInsts = [FamInst]
famInsts1 [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
famInsts2
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; [FamInst]
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv [FamInst]
famInsts (TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn))
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall a b. (a -> b) -> a -> b
$
do { [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
given_inst_binds <- (DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> [DerivSpec ThetaType]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds [DerivSpec ThetaType]
given_specs
; let given_inst_infos :: [InstInfo GhcPs]
given_inst_infos = ((InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs)
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])] -> [InstInfo GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs
forall a b c. (a, b, c) -> a
fstOf3 [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
given_inst_binds
; [DerivSpec ThetaType]
final_infer_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]
given_inst_infos) (TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType])
-> TcM [DerivSpec ThetaType] -> TcM [DerivSpec ThetaType]
forall a b. (a -> b) -> a -> b
$
[DerivSpec ThetaSpec] -> TcM [DerivSpec ThetaType]
simplifyInstanceContexts [DerivSpec ThetaSpec]
infer_specs
; [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
infer_inst_binds <- (DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> [DerivSpec ThetaType]
-> IOEnv
(Env TcGblEnv TcLclEnv) [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds [DerivSpec ThetaType]
final_infer_specs
; let ([InstInfo GhcPs]
_, [Bag AuxBindSpec]
aux_specs, [[Name]]
fvs) = [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
-> ([InstInfo GhcPs], [Bag AuxBindSpec], [[Name]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
given_inst_binds [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
forall a. [a] -> [a] -> [a]
++ [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
infer_inst_binds)
; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; let aux_binds :: Bag (LHsBind GhcPs, LSig GhcPs)
aux_binds = DynFlags
-> SrcSpan -> Bag AuxBindSpec -> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds DynFlags
dflags SrcSpan
loc ([Bag AuxBindSpec] -> Bag AuxBindSpec
forall a. [Bag a] -> Bag a
unionManyBags [Bag AuxBindSpec]
aux_specs)
; let infer_inst_infos :: [InstInfo GhcPs]
infer_inst_infos = ((InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs)
-> [(InstInfo GhcPs, Bag AuxBindSpec, [Name])] -> [InstInfo GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (InstInfo GhcPs, Bag AuxBindSpec, [Name]) -> InstInfo GhcPs
forall a b c. (a, b, c) -> a
fstOf3 [(InstInfo GhcPs, Bag AuxBindSpec, [Name])]
infer_inst_binds
; let inst_infos :: [InstInfo GhcPs]
inst_infos = [InstInfo GhcPs]
given_inst_infos [InstInfo GhcPs] -> [InstInfo GhcPs] -> [InstInfo GhcPs]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcPs]
infer_inst_infos
; (Bag (InstInfo GhcRn)
inst_info, HsValBinds GhcRn
rn_aux_binds, DefUses
rn_dus) <- [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
aux_binds
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag (InstInfo GhcRn) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (InstInfo GhcRn)
inst_info) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IO () -> TcRn ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_deriv String
"Derived instances"
DumpFormat
FormatHaskell
(Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> [FamInst] -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_info HsValBinds GhcRn
rn_aux_binds [FamInst]
famInsts))
; TcGblEnv
gbl_env <- [ClsInst]
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv ((InstInfo GhcRn -> ClsInst) -> [InstInfo GhcRn] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo GhcRn -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_info))
TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let all_dus :: DefUses
all_dus = DefUses
rn_dus DefUses -> DefUses -> DefUses
`plusDU` Uses -> DefUses
usesOnly ([Name] -> Uses
NameSet.mkFVs ([Name] -> Uses) -> [Name] -> Uses
forall a b. (a -> b) -> a -> b
$ [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Name]]
fvs)
; (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> DefUses -> TcGblEnv
addTcgDUs TcGblEnv
gbl_env DefUses
all_dus, Bag (InstInfo GhcRn)
inst_info, HsValBinds GhcRn
rn_aux_binds) } }
where
ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
-> [FamInst]
-> SDoc
ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn -> [FamInst] -> SDoc
ddump_deriving Bag (InstInfo GhcRn)
inst_infos HsValBinds GhcRn
extra_binds [FamInst]
famInsts
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Derived class instances:")
Int
2 ([SDoc] -> SDoc
vcat ((InstInfo GhcRn -> SDoc) -> [InstInfo GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcRn
i -> InstInfo GhcRn -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcRn
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"") (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
$$ SDoc -> SDoc -> SDoc
hangP (String -> SDoc
text String
"Derived type family instances:")
([SDoc] -> SDoc
vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
pprRepTy [FamInst]
famInsts))
hangP :: SDoc -> SDoc -> SDoc
hangP SDoc
s SDoc
x = String -> SDoc
text String
"" SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
s Int
2 SDoc
x
pprRepTy :: FamInst -> SDoc
pprRepTy :: FamInst -> SDoc
pprRepTy fi :: FamInst
fi@(FamInst { fi_tys :: FamInst -> ThetaType
fi_tys = ThetaType
lhs })
= String -> SDoc
text String
"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 :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
= TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. TcRn a -> TcRn a
discardWarnings (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
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
$
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
$
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
$
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
$
Extension
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.TemplateHaskellQuotes (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
do {
; String -> SDoc -> TcRn ()
traceTc String
"rnd" ([SDoc] -> SDoc
vcat ((InstInfo GhcPs -> SDoc) -> [InstInfo GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcPs
i -> InstInfo GhcPs -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcPs
i SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"") [InstInfo GhcPs]
inst_infos))
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
aux_binds, Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs) <- ((GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs)))
-> Bag
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag (GenLocated SrcSpanAnnA (Sig GhcPs)))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (b, c)) -> Bag a -> m (Bag b, Bag c)
mapAndUnzipBagM (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return Bag (LHsBind GhcPs, LSig GhcPs)
Bag
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
bagBinds
; let aux_val_binds :: HsValBindsLR GhcPs GhcPs
aux_val_binds = XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
AnnSortKey
NoAnnSortKey LHsBindsLR GhcPs GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
aux_binds (Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs)
; ([Name]
bndrs, HsValBindsLR GhcRn GhcPs
rn_aux_lhs) <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
forall a. FastStringEnv a
emptyFsEnv HsValBindsLR GhcPs GhcPs
aux_val_binds
; [Name]
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. [Name] -> RnM a -> RnM a
bindLocalNames [Name]
bndrs (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
do { (HsValBinds GhcRn
rn_aux, DefUses
dus_aux) <- Uses -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses)
rnLocalValBindsRHS ([Name] -> Uses
mkNameSet [Name]
bndrs) HsValBindsLR GhcRn GhcPs
rn_aux_lhs
; ([InstInfo GhcRn]
rn_inst_infos, [Uses]
fvs_insts) <- (InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses))
-> [InstInfo GhcPs]
-> IOEnv (Env TcGblEnv TcLclEnv) ([InstInfo GhcRn], [Uses])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info [InstInfo GhcPs]
inst_infos
; (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall (m :: * -> *) a. Monad m => a -> m a
return ([InstInfo GhcRn] -> Bag (InstInfo GhcRn)
forall a. [a] -> Bag a
listToBag [InstInfo GhcRn]
rn_inst_infos, HsValBinds GhcRn
rn_aux,
DefUses
dus_aux DefUses -> DefUses -> DefUses
`plusDU` Uses -> DefUses
usesOnly ([Uses] -> Uses
plusFVs [Uses]
fvs_insts)) } }
where
rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
rn_inst_info :: InstInfo GhcPs
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
rn_inst_info
inst_info :: InstInfo GhcPs
inst_info@(InstInfo { iSpec :: forall a. InstInfo a -> ClsInst
iSpec = ClsInst
inst
, iBinds :: forall a. InstInfo a -> InstBindings a
iBinds = InstBindings
{ ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBindsLR GhcPs GhcPs
binds
, ib_tyvars :: forall a. InstBindings a -> [Name]
ib_tyvars = [Name]
tyvars
, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig GhcPs]
sigs
, ib_extensions :: forall a. InstBindings a -> [Extension]
ib_extensions = [Extension]
exts
, ib_derived :: forall a. InstBindings a -> Bool
ib_derived = Bool
sa } })
= do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
rn_binds, [GenLocated SrcSpanAnnA (Sig GhcRn)]
rn_sigs, Uses
fvs) <- Bool
-> Name
-> [Name]
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> RnM (LHsBinds GhcRn, [LSig GhcRn], Uses)
rnMethodBinds Bool
False (ClsInst -> Name
is_cls_nm ClsInst
inst)
[Name]
tyvars LHsBindsLR GhcPs GhcPs
binds [LSig GhcPs]
sigs
; let binds' :: InstBindings GhcRn
binds' = InstBindings :: forall a.
[Name]
-> LHsBinds a -> [LSig a] -> [Extension] -> Bool -> InstBindings a
InstBindings { ib_binds :: LHsBinds GhcRn
ib_binds = LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
rn_binds
, ib_tyvars :: [Name]
ib_tyvars = [Name]
tyvars
, ib_pragmas :: [LSig GhcRn]
ib_pragmas = [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
rn_sigs
, ib_extensions :: [Extension]
ib_extensions = [Extension]
exts
, ib_derived :: Bool
ib_derived = Bool
sa }
; (InstInfo GhcRn, Uses)
-> IOEnv (Env TcGblEnv TcLclEnv) (InstInfo GhcRn, Uses)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs
inst_info { iBinds :: InstBindings GhcRn
iBinds = InstBindings GhcRn
binds' }, Uses
fvs) }
makeDerivSpecs :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM [EarlyDerivSpec]
makeDerivSpecs :: [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
= do { [[EarlyDerivSpec]]
eqns1 <- [TcM [EarlyDerivSpec]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[EarlyDerivSpec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
dcs (LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds LDerivClauseTys GhcRn
dct) SDoc
err_ctxt
| DerivInfo { di_rep_tc :: DerivInfo -> TyCon
di_rep_tc = TyCon
rep_tc
, di_scoped_tvs :: DerivInfo -> [(Name, TyVar)]
di_scoped_tvs = [(Name, TyVar)]
scoped_tvs
, di_clauses :: DerivInfo -> [LHsDerivingClause GhcRn]
di_clauses = [LHsDerivingClause GhcRn]
clauses
, di_ctxt :: DerivInfo -> SDoc
di_ctxt = SDoc
err_ctxt } <- [DerivInfo]
deriv_infos
, L SrcAnn NoEpAnns
_ (HsDerivingClause { deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_strategy = Maybe (LDerivStrategy GhcRn)
dcs
, deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys = LDerivClauseTys GhcRn
dct })
<- [LHsDerivingClause GhcRn]
[GenLocated (SrcAnn NoEpAnns) (HsDerivingClause GhcRn)]
clauses
]
; [Maybe EarlyDerivSpec]
eqns2 <- (GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [GenLocated SrcSpanAnnA (DerivDecl GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe EarlyDerivSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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))
-> (GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
GenLocated SrcSpanAnnA (DerivDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone) [LDerivDecl GhcRn]
[GenLocated SrcSpanAnnA (DerivDecl GhcRn)]
deriv_decls
; [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ [[EarlyDerivSpec]] -> [EarlyDerivSpec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EarlyDerivSpec]]
eqns1 [EarlyDerivSpec] -> [EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [a] -> [a] -> [a]
++ [Maybe EarlyDerivSpec] -> [EarlyDerivSpec]
forall a. [Maybe a] -> [a]
catMaybes [Maybe EarlyDerivSpec]
eqns2 }
where
deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds (L _ dct) = case DerivClauseTys GhcRn
dct of
DctSingle XDctSingle GhcRn
_ LHsSigType GhcRn
ty -> [LHsSigType GhcRn
ty]
DctMulti XDctMulti GhcRn
_ [LHsSigType GhcRn]
tys -> [LHsSigType GhcRn]
tys
deriveClause :: TyCon
-> [(Name, TcTyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn] -> SDoc
-> TcM [EarlyDerivSpec]
deriveClause :: TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat [LHsSigType GhcRn]
deriv_preds SDoc
err_ctxt
= SDoc -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcRn ()
traceTc String
"deriveClause" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
, String -> SDoc
text String
"scoped_tvs" SDoc -> SDoc -> SDoc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
scoped_tvs
, String -> SDoc
text String
"tc" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tys" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
tys
, String -> SDoc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
<+> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mb_lderiv_strat ]
[(Name, TyVar)] -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
scoped_tvs (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat', [TyVar]
via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
[TyVar] -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
via_tvs (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> TcM [EarlyDerivSpec]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (TyCon
-> ThetaType
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc ThetaType
tys Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat' [TyVar]
via_tvs) [LHsSigType GhcRn]
[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
deriv_preds
where
tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
(TyCon
tc, ThetaType
tys) = case TyCon -> Maybe (TyCon, ThetaType, CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
rep_tc of
Just (TyCon
fam_tc, ThetaType
pats, CoAxiom Unbranched
_) -> (TyCon
fam_tc, ThetaType
pats)
Maybe (TyCon, ThetaType, CoAxiom Unbranched)
_ -> (TyCon
rep_tc, [TyVar] -> ThetaType
mkTyVarTys [TyVar]
tvs)
derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]
-> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)
derivePred :: TyCon
-> ThetaType
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc ThetaType
tys Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat [TyVar]
via_tvs LHsSigType GhcRn
deriv_pred =
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))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcRn ()
traceTc String
"derivePred" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tc" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tys" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
tys
, String -> SDoc
text String
"deriv_pred" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred
, String -> SDoc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
<+> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat
, String -> SDoc
text String
"via_tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
via_tvs ]
([TyVar]
cls_tvs, Class
cls, ThetaType
cls_tys, ThetaType
cls_arg_kinds) <- 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` Int
1) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (LHsSigType GhcRn -> TcRnMessage
TcRnNonUnaryTypeclassConstraint LHsSigType GhcRn
deriv_pred)
let [Type
cls_arg_kind] = ThetaType
cls_arg_kinds
mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat = (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> DerivStrategy GhcTc)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat
if (Class -> Name
className Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName)
then do TcRn ()
warnUselessTypeable
Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlyDerivSpec
forall a. Maybe a
Nothing
else let deriv_tvs :: [TyVar]
deriv_tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs in
EarlyDerivSpec -> Maybe EarlyDerivSpec
forall a. a -> Maybe a
Just (EarlyDerivSpec -> Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> ThetaType
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc ThetaType
tys Maybe (DerivStrategy GhcTc)
mb_deriv_strat
[TyVar]
deriv_tvs Class
cls ThetaType
cls_tys Type
cls_arg_kind
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
deriveStandalone :: LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
= SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
deriv_ty) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving decl for" (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
deriv_ty)
; let ctxt :: UserTypeCtxt
ctxt = Bool -> UserTypeCtxt
GHC.Tc.Types.Origin.InstDeclCtxt Bool
True
; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (standalone deriving)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcRn))
mb_lderiv_strat, HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
deriv_ty]
; (Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat, [TyVar]
via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (standalone deriving) 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
via_tvs]
; ([TyVar]
cls_tvs, DerivContext
deriv_ctxt, Class
cls, ThetaType
inst_tys)
<- [TyVar]
-> TcM ([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType)
forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar]
via_tvs (TcM ([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType))
-> TcM ([TyVar], DerivContext, Class, ThetaType)
-> TcM ([TyVar], DerivContext, Class, ThetaType)
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, ThetaType)
tcStandaloneDerivInstType UserTypeCtxt
ctxt LHsSigWcType GhcRn
deriv_ty
; let mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
mb_deriv_strat = (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> DerivStrategy GhcTc)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
mb_lderiv_strat
tvs :: [TyVar]
tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs
; ([TyVar]
tvs', DerivContext
deriv_ctxt', ThetaType
inst_tys', Maybe (DerivStrategy GhcTc)
mb_deriv_strat') <-
case Maybe (DerivStrategy GhcTc)
mb_deriv_strat of
Just (ViaStrategy XViaStrategy GhcTc
via_ty)
| Just Type
inst_ty <- ThetaType -> Maybe Type
forall a. [a] -> Maybe a
lastMaybe ThetaType
inst_tys
-> do
let via_kind :: Type
via_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind XViaStrategy GhcTc
Type
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 -> TcRnMessage -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
(Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type -> DeriveInstanceErrReason
DerivErrDerivingViaWrongKind Type
inst_ty_kind XViaStrategy GhcTc
Type
via_ty Type
via_kind)
let Just TCvSubst
kind_subst = Maybe TCvSubst
mb_match
ki_subst_range :: VarSet
ki_subst_range = TCvSubst -> VarSet
getTCvSubstRangeFVs TCvSubst
kind_subst
unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\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
(TCvSubst
subst, [TyVar]
_) = HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
unmapped_tkvs
(DerivContext
final_deriv_ctxt, ThetaType
final_deriv_ctxt_tys)
= case DerivContext
deriv_ctxt of
InferContext Maybe SrcSpan
wc -> (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
wc, [])
SupplyContext ThetaType
theta ->
let final_theta :: ThetaType
final_theta = HasDebugCallStack => 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 = HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
inst_tys
final_via_ty :: Type
final_via_ty = HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst XViaStrategy GhcTc
Type
via_ty
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
ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
final_via_ty]
([TyVar], DerivContext, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], DerivContext, ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
final_tvs, DerivContext
final_deriv_ctxt, ThetaType
final_inst_tys
, DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a. a -> Maybe a
Just (XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcTc
Type
final_via_ty) )
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], DerivContext, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], DerivContext, ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, DerivContext
deriv_ctxt, ThetaType
inst_tys, Maybe (DerivStrategy GhcTc)
mb_deriv_strat)
; String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving;" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tvs':" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs'
, String -> SDoc
text String
"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 String
"deriv_ctxt':" SDoc -> SDoc -> SDoc
<+> DerivContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivContext
deriv_ctxt'
, String -> SDoc
text String
"cls:" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
, String -> SDoc
text String
"inst_tys':" SDoc -> SDoc -> SDoc
<+> ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
inst_tys' ]
; 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 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
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp ((GenLocated SrcSpanAnnP OverlapMode -> OverlapMode)
-> Maybe (GenLocated SrcSpanAnnP OverlapMode) -> Maybe OverlapMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP OverlapMode -> OverlapMode
forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn OverlapMode)
Maybe (GenLocated SrcSpanAnnP OverlapMode)
overlap_mode)
[TyVar]
tvs' Class
cls ThetaType
inst_tys'
DerivContext
deriv_ctxt' Maybe (DerivStrategy GhcTc)
mb_deriv_strat' }
tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType :: UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, ThetaType)
tcStandaloneDerivInstType UserTypeCtxt
ctxt
(HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = deriv_ty :: LHsSigType GhcRn
deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs
, sig_body = deriv_ty_body }))})
| (Maybe (LHsContext GhcRn)
theta, LHsType GhcRn
rho) <- LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
deriv_ty_body
, [LHsType GhcRn
wc_pred] <- Maybe (LHsContext GhcRn) -> [LHsType GhcRn]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
theta
, L wc_span (HsWildCardTy _) <- LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens LHsType GhcRn
wc_pred
= do Type
dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt (LHsSigType GhcRn -> TcM Type) -> LHsSigType GhcRn -> TcM Type
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$
HsSig :: forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig { sig_ext :: XHsSig GhcRn
sig_ext = NoExtField
XHsSig GhcRn
noExtField
, sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
, sig_body :: LHsType GhcRn
sig_body = LHsType GhcRn
rho }
let ([TyVar]
tvs, ThetaType
_theta, Class
cls, 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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
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 ([TyVar]
tvs, ThetaType
theta, Class
cls, 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)
warnUselessTypeable :: TcM ()
warnUselessTypeable :: TcRn ()
warnUselessTypeable = TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
TcRnUselessTypeable
deriveTyData :: TyCon -> [Type]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [Type]
-> Kind
-> TcM EarlyDerivSpec
deriveTyData :: TyCon
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> ThetaType
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc ThetaType
tc_args Maybe (DerivStrategy GhcTc)
mb_deriv_strat [TyVar]
deriv_tvs Class
cls ThetaType
cls_tys Type
cls_arg_kind
= do {
let ([Scaled Type]
arg_kinds, Type
_) = Type -> ([Scaled Type], Type)
splitFunTys Type
cls_arg_kind
n_args_to_drop :: Int
n_args_to_drop = [Scaled Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
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
(ThetaType
tc_args_to_keep, 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)
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
>= Int
0
; Bool -> TcRnMessage -> TcRn ()
checkTc (Bool
enough_args Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_match)
(Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
cls_tys Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
TyCon -> Type -> Int -> DeriveInstanceErrReason
DerivErrNotWellKinded TyCon
tc Type
cls_arg_kind Int
n_args_to_keep)
; let
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> ThetaType
deriv_strat_tys = (DerivStrategy GhcTc -> ThetaType)
-> Maybe (DerivStrategy GhcTc) -> ThetaType
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ThetaType
-> (XViaStrategy GhcTc -> ThetaType)
-> DerivStrategy GhcTc
-> ThetaType
forall p (pass :: Pass) r.
(p ~ GhcPass pass) =>
r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
foldDerivStrategy [] (Type -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
:[]))
propagate_subst :: TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs' ThetaType
cls_tys' ThetaType
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
= ([TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat)
where
ki_subst_range :: VarSet
ki_subst_range = TCvSubst -> VarSet
getTCvSubstRangeFVs TCvSubst
kind_subst
unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\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'
(TCvSubst
subst, [TyVar]
_) = HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
unmapped_tkvs
final_tc_args :: ThetaType
final_tc_args = HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
tc_args'
final_cls_tys :: ThetaType
final_cls_tys = HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
subst ThetaType
cls_tys'
final_mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst))
Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
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
ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ Maybe (DerivStrategy GhcTc) -> ThetaType
deriv_strat_tys Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
; let tkvs :: [TyVar]
tkvs = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ FV -> [TyVar]
fvVarList (FV -> [TyVar]) -> FV -> [TyVar]
forall a b. (a -> b) -> a -> b
$
FV -> FV -> FV
unionFV (ThetaType -> FV
tyCoFVsOfTypes ThetaType
tc_args_to_keep)
([TyVar] -> FV
FV.mkFVs [TyVar]
deriv_tvs)
Just TCvSubst
kind_subst = Maybe TCvSubst
mb_match
([TyVar]
tkvs', ThetaType
cls_tys', ThetaType
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
= TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
propagate_subst TCvSubst
kind_subst [TyVar]
tkvs ThetaType
cls_tys
ThetaType
tc_args_to_keep Maybe (DerivStrategy GhcTc)
mb_deriv_strat
; ([TyVar]
final_tkvs, ThetaType
final_cls_tys, ThetaType
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat) <-
case Maybe (DerivStrategy GhcTc)
mb_deriv_strat' of
Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
let via_kind :: Type
via_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind XViaStrategy GhcTc
Type
via_ty
inst_ty_kind :: Type
inst_ty_kind
= HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind (TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
tc_args')
via_match :: Maybe TCvSubst
via_match = Type -> Type -> Maybe TCvSubst
tcUnifyTy Type
inst_ty_kind Type
via_kind
Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust Maybe TCvSubst
via_match)
(Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type -> DeriveInstanceErrReason
DerivErrDerivingViaWrongKind Type
inst_ty_kind XViaStrategy GhcTc
Type
via_ty Type
via_kind)
let Just TCvSubst
via_subst = Maybe TCvSubst
via_match
([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], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc)))
-> ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
forall a b. (a -> b) -> a -> b
$ TCvSubst
-> [TyVar]
-> ThetaType
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], ThetaType, ThetaType, Maybe (DerivStrategy GhcTc))
propagate_subst TCvSubst
via_subst [TyVar]
tkvs' ThetaType
cls_tys'
ThetaType
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
Maybe (DerivStrategy GhcTc)
_ -> ([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
cls_tys', ThetaType
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 1" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ Maybe (DerivStrategy GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat, [TyVar] -> SDoc
pprTyVars [TyVar]
deriv_tvs, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, ThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThetaType
tc_args
, [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 String
"deriveTyData 2" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
final_tkvs ]
; let final_tc_app :: Type
final_tc_app = TyCon -> ThetaType -> Type
mkTyConApp TyCon
tc ThetaType
final_tc_args
final_cls_args :: ThetaType
final_cls_args = ThetaType
final_cls_tys ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ [Type
final_tc_app]
; Bool -> TcRnMessage -> TcRn ()
checkTc (VarSet -> ThetaType -> Bool
allDistinctTyVars ([TyVar] -> VarSet
mkVarSet [TyVar]
final_tkvs) ThetaType
args_to_drop)
(Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
final_cls_tys Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Type -> DeriveInstanceErrReason
DerivErrNoEtaReduce Type
final_tc_app)
; UserTypeCtxt -> Class -> ThetaType -> TcRn ()
checkValidInstHead UserTypeCtxt
DerivClauseCtxt Class
cls ThetaType
final_cls_args
; EarlyDerivSpec
spec <- Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
forall a. Maybe a
Nothing [TyVar]
final_tkvs Class
cls ThetaType
final_cls_args
(Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
forall a. Maybe a
Nothing) Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData 3" (EarlyDerivSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr EarlyDerivSpec
spec)
; EarlyDerivSpec -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall (m :: * -> *) a. Monad m => a -> m a
return EarlyDerivSpec
spec }
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> TcRn EarlyDerivSpec
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
overlap_mode [TyVar]
tvs Class
cls ThetaType
cls_args DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
deriv_strat = do
Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_boot (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ DeriveInstanceErrReason -> TcRn ()
bale_out DeriveInstanceErrReason
DerivErrBootFileFound
let pred :: Type
pred = Class -> ThetaType -> Type
mkClassPred Class
cls ThetaType
cls_args
SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (Type -> SkolemInfoAnon
DerivSkol Type
pred)
([TyVar]
tvs', ThetaType
cls_args', Maybe (DerivStrategy GhcTc)
deriv_strat') <-
SkolemInfo
-> DerivContext
-> TcM ([TyVar], ThetaType, Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context SkolemInfo
skol_info DerivContext
deriv_ctxt
let deriv_env :: DerivEnv
deriv_env = DerivEnv :: Maybe OverlapMode
-> [TyVar]
-> Class
-> ThetaType
-> DerivContext
-> SkolemInfo
-> 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_inst_tys :: ThetaType
denv_inst_tys = ThetaType
cls_args'
, denv_ctxt :: DerivContext
denv_ctxt = DerivContext
deriv_ctxt
, denv_skol_info :: SkolemInfo
denv_skol_info = SkolemInfo
skol_info
, denv_strat :: Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
deriv_strat' }
ReaderT DerivEnv TcRn EarlyDerivSpec
-> DerivEnv -> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn DerivEnv
deriv_env
where
skolemise_when_inferring_context ::
SkolemInfo -> DerivContext
-> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context :: SkolemInfo
-> DerivContext
-> TcM ([TyVar], ThetaType, Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context SkolemInfo
skol_info DerivContext
deriv_ctxt =
case DerivContext
deriv_ctxt of
InferContext{} -> do
(TCvSubst
skol_subst, [TyVar]
tvs') <- SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TyVar])
tcInstSkolTyVars SkolemInfo
skol_info [TyVar]
tvs
let cls_args' :: ThetaType
cls_args' = HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType
TCvSubst -> ThetaType -> ThetaType
substTys TCvSubst
skol_subst ThetaType
cls_args
deriv_strat' :: Maybe (DerivStrategy GhcTc)
deriv_strat' = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
skol_subst))
Maybe (DerivStrategy GhcTc)
deriv_strat
([TyVar], ThetaType, Maybe (DerivStrategy GhcTc))
-> TcM ([TyVar], ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs', ThetaType
cls_args', Maybe (DerivStrategy GhcTc)
deriv_strat')
SupplyContext{} -> ([TyVar], ThetaType, Maybe (DerivStrategy GhcTc))
-> TcM ([TyVar], ThetaType, Maybe (DerivStrategy GhcTc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, ThetaType
cls_args, Maybe (DerivStrategy GhcTc)
deriv_strat)
bale_out :: DeriveInstanceErrReason -> TcRn ()
bale_out =
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ())
-> (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason
-> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
cls_args Maybe (DerivStrategy GhcTc)
deriv_strat UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
mk_eqn :: DerivM EarlyDerivSpec
mk_eqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn = do
DerivEnv { denv_inst_tys :: DerivEnv -> ThetaType
denv_inst_tys = ThetaType
cls_args
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
case Maybe (DerivStrategy GhcTc)
mb_strat of
Just (StockStrategy XStockStrategy GhcTc
_) -> do
(ThetaType
cls_tys, Type
inst_ty) <- ThetaType -> DerivM (ThetaType, Type)
expectNonNullaryClsArgs ThetaType
cls_args
DerivInstTys
dit <- ThetaType -> Type -> DerivM DerivInstTys
expectAlgTyConApp ThetaType
cls_tys Type
inst_ty
DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivInstTys
dit
Just (AnyclassStrategy XAnyClassStrategy GhcTc
_) -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
(ThetaType
cls_tys, Type
inst_ty) <- ThetaType -> DerivM (ThetaType, Type)
expectNonNullaryClsArgs ThetaType
cls_args
ThetaType -> Type -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via ThetaType
cls_tys Type
inst_ty XViaStrategy GhcTc
Type
via_ty
Just (NewtypeStrategy XNewtypeStrategy GhcTc
_) -> do
(ThetaType
cls_tys, Type
inst_ty) <- ThetaType -> DerivM (ThetaType, Type)
expectNonNullaryClsArgs ThetaType
cls_args
DerivInstTys
dit <- ThetaType -> Type -> DerivM DerivInstTys
expectAlgTyConApp ThetaType
cls_tys Type
inst_ty
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isNewTyCon (DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit)) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrGNDUsedOnData
Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
True DerivInstTys
dit
Maybe (DerivStrategy GhcTc)
Nothing -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs :: ThetaType -> DerivM (ThetaType, Type)
expectNonNullaryClsArgs ThetaType
inst_tys =
DerivM (ThetaType, Type)
-> ((ThetaType, Type) -> DerivM (ThetaType, Type))
-> Maybe (ThetaType, Type)
-> DerivM (ThetaType, Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM (ThetaType, Type)
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrNullaryClasses) (ThetaType, Type) -> DerivM (ThetaType, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ThetaType, Type) -> DerivM (ThetaType, Type))
-> Maybe (ThetaType, Type) -> DerivM (ThetaType, Type)
forall a b. (a -> b) -> a -> b
$
ThetaType -> Maybe (ThetaType, Type)
forall a. [a] -> Maybe ([a], a)
snocView ThetaType
inst_tys
expectAlgTyConApp :: [Type]
-> Type
-> DerivM DerivInstTys
expectAlgTyConApp :: ThetaType -> Type -> DerivM DerivInstTys
expectAlgTyConApp ThetaType
cls_tys Type
inst_ty = do
FamInstEnvs
fam_envs <- IOEnv (Env TcGblEnv TcLclEnv) FamInstEnvs
-> ReaderT DerivEnv TcRn FamInstEnvs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv (Env TcGblEnv TcLclEnv) FamInstEnvs
tcGetFamInstEnvs
case FamInstEnvs -> ThetaType -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs ThetaType
cls_tys Type
inst_ty of
Maybe DerivInstTys
Nothing -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM DerivInstTys
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrLastArgMustBeApp
Just DerivInstTys
dit -> do DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
DerivInstTys -> DerivM DerivInstTys
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivInstTys
dit
expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
expectNonDataFamTyCon :: DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_tc_args :: DerivInstTys -> ThetaType
dit_tc_args = ThetaType
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) =
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isDataFamilyTyCon TyCon
rep_tc) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ())
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
TyCon -> ThetaType -> DeriveInstanceErrReason
DerivErrNoFamilyInstance TyCon
tc ThetaType
tc_args
mk_deriv_inst_tys_maybe :: FamInstEnvs
-> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe :: FamInstEnvs -> ThetaType -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs ThetaType
cls_tys Type
inst_ty =
((TyCon, ThetaType) -> DerivInstTys)
-> Maybe (TyCon, ThetaType) -> Maybe DerivInstTys
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon, ThetaType) -> DerivInstTys
lookup (Maybe (TyCon, ThetaType) -> Maybe DerivInstTys)
-> Maybe (TyCon, ThetaType) -> Maybe DerivInstTys
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe Type
inst_ty
where
lookup :: (TyCon, [Type]) -> DerivInstTys
lookup :: (TyCon, ThetaType) -> DerivInstTys
lookup (TyCon
tc, ThetaType
tc_args) =
let (TyCon
rep_tc, ThetaType
rep_tc_args, Coercion
_co) = FamInstEnvs -> TyCon -> ThetaType -> (TyCon, ThetaType, Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc ThetaType
tc_args
dc_inst_arg_env :: DataConEnv ThetaType
dc_inst_arg_env = TyCon -> ThetaType -> DataConEnv ThetaType
buildDataConInstArgEnv TyCon
rep_tc ThetaType
rep_tc_args
in DerivInstTys :: ThetaType
-> TyCon
-> ThetaType
-> TyCon
-> ThetaType
-> DataConEnv ThetaType
-> DerivInstTys
DerivInstTys { dit_cls_tys :: ThetaType
dit_cls_tys = ThetaType
cls_tys
, dit_tc :: TyCon
dit_tc = TyCon
tc
, dit_tc_args :: ThetaType
dit_tc_args = ThetaType
tc_args
, dit_rep_tc :: TyCon
dit_rep_tc = TyCon
rep_tc
, dit_rep_tc_args :: ThetaType
dit_rep_tc_args = ThetaType
rep_tc_args
, dit_dc_inst_arg_env :: DataConEnv ThetaType
dit_dc_inst_arg_env = DataConEnv ThetaType
dc_inst_arg_env }
mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
mk_eqn_from_mechanism :: DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
mechanism
= do DerivEnv { denv_overlap_mode :: DerivEnv -> Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
, denv_tvs :: DerivEnv -> [TyVar]
denv_tvs = [TyVar]
tvs
, denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> ThetaType
denv_inst_tys = ThetaType
inst_tys
, denv_ctxt :: DerivEnv -> DerivContext
denv_ctxt = DerivContext
deriv_ctxt
, denv_skol_info :: DerivEnv -> SkolemInfo
denv_skol_info = SkolemInfo
skol_info } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
UserTypeCtxt
user_ctxt <- DerivM UserTypeCtxt
askDerivUserTypeCtxt
DerivSpecMechanism -> ReaderT DerivEnv TcRn ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism
SrcSpan
loc <- TcRn SrcSpan -> ReaderT DerivEnv TcRn SrcSpan
forall (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 -> ThetaType -> SrcSpan -> IOEnv (Env TcGblEnv TcLclEnv) Name
newDFunName Class
cls ThetaType
inst_tys SrcSpan
loc
case DerivContext
deriv_ctxt of
InferContext Maybe SrcSpan
wildcard ->
do { (ThetaSpec
inferred_constraints, [TyVar]
tvs', ThetaType
inst_tys', DerivSpecMechanism
mechanism')
<- DerivSpecMechanism
-> DerivM (ThetaSpec, [TyVar], ThetaType, DerivSpecMechanism)
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 ThetaSpec -> EarlyDerivSpec
InferTheta (DerivSpec ThetaSpec -> EarlyDerivSpec)
-> DerivSpec ThetaSpec -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS :: forall theta.
SrcSpan
-> Name
-> [TyVar]
-> theta
-> Class
-> ThetaType
-> SkolemInfo
-> UserTypeCtxt
-> 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_theta :: ThetaSpec
ds_theta = ThetaSpec
inferred_constraints
, ds_skol_info :: SkolemInfo
ds_skol_info = SkolemInfo
skol_info
, ds_user_ctxt :: UserTypeCtxt
ds_user_ctxt = UserTypeCtxt
user_ctxt
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism' } }
SupplyContext 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
-> SkolemInfo
-> UserTypeCtxt
-> 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_theta :: ThetaType
ds_theta = ThetaType
theta
, ds_skol_info :: SkolemInfo
ds_skol_info = SkolemInfo
skol_info
, ds_user_ctxt :: UserTypeCtxt
ds_user_ctxt = UserTypeCtxt
user_ctxt
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
forall a. Maybe a
Nothing
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism }
mk_eqn_stock :: DerivInstTys
-> DerivM EarlyDerivSpec
mk_eqn_stock :: DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivInstTys
dit
= do DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let isDeriveAnyClassEnabled :: DeriveAnyClassEnabled
isDeriveAnyClassEnabled =
Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions DerivInstTys
dit DerivM OriginativeDerivStatus
-> (OriginativeDerivStatus -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock :: DerivInstTys -> StockGenFns -> DerivSpecMechanism
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns }
StockClassError DeriveInstanceErrReason
why -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
why
OriginativeDerivStatus
CanDeriveAnyClass -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
(DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled)
OriginativeDerivStatus
NonDerivableClass -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
(DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
YesDeriveAnyClassEnabled)
mk_eqn_anyclass :: DerivM EarlyDerivSpec
mk_eqn_anyclass :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
= do DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let isDeriveAnyClassEnabled :: DeriveAnyClassEnabled
isDeriveAnyClassEnabled =
Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
case Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags of
Bool
True -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
Bool
False -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
(DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled)
mk_eqn_newtype :: DerivInstTys
-> Type
-> DerivM EarlyDerivSpec
mk_eqn_newtype :: DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_ty =
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpecNewtype :: DerivInstTys -> Type -> DerivSpecMechanism
DerivSpecNewtype { dsm_newtype_dit :: DerivInstTys
dsm_newtype_dit = DerivInstTys
dit
, dsm_newtype_rep_ty :: Type
dsm_newtype_rep_ty = Type
rep_ty }
mk_eqn_via :: [Type]
-> Type
-> Type
-> DerivM EarlyDerivSpec
mk_eqn_via :: ThetaType -> Type -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via ThetaType
cls_tys Type
inst_ty Type
via_ty =
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpecVia :: ThetaType -> Type -> Type -> DerivSpecMechanism
DerivSpecVia { dsm_via_cls_tys :: ThetaType
dsm_via_cls_tys = ThetaType
cls_tys
, dsm_via_inst_ty :: Type
dsm_via_inst_ty = Type
inst_ty
, dsm_via_ty :: Type
dsm_via_ty = Type
via_ty }
mk_eqn_no_strategy :: DerivM EarlyDerivSpec
mk_eqn_no_strategy :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy = do
DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> ThetaType
denv_inst_tys = ThetaType
cls_args } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
FamInstEnvs
fam_envs <- IOEnv (Env TcGblEnv TcLclEnv) FamInstEnvs
-> ReaderT DerivEnv TcRn FamInstEnvs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IOEnv (Env TcGblEnv TcLclEnv) FamInstEnvs
tcGetFamInstEnvs
if | Just (ThetaType
cls_tys, Type
inst_ty) <- ThetaType -> Maybe (ThetaType, Type)
forall a. [a] -> Maybe ([a], a)
snocView ThetaType
cls_args
, Just DerivInstTys
dit <- FamInstEnvs -> ThetaType -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs ThetaType
cls_tys Type
inst_ty
-> if | TyCon -> Bool
isNewTyCon (DerivInstTys -> TyCon
dit_rep_tc DerivInstTys
dit)
-> Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
False DerivInstTys
dit
| Bool
otherwise
-> do
Maybe StockGenFns
-> (StockGenFns -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Class -> Maybe StockGenFns
hasStockDeriving Class
cls) ((StockGenFns -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ())
-> (StockGenFns -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ \StockGenFns
_ ->
DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative DerivInstTys
dit
| Bool
otherwise
-> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
where
mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec
mk_eqn_originative :: DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative dit :: DerivInstTys
dit@(DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let isDeriveAnyClassEnabled :: DeriveAnyClassEnabled
isDeriveAnyClassEnabled =
Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
let dac_error :: DeriveInstanceErrReason
dac_error
| TyCon -> Bool
isClassTyCon TyCon
rep_tc
= TyCon -> DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrOnlyAnyClassDeriveable TyCon
tc DeriveAnyClassEnabled
isDeriveAnyClassEnabled
| Bool
otherwise
= DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled
DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions DerivInstTys
dit DerivM OriginativeDerivStatus
-> (OriginativeDerivStatus -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
OriginativeDerivStatus
NonDerivableClass -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
dac_error
StockClassError DeriveInstanceErrReason
why -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
why
CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock :: DerivInstTys -> StockGenFns -> DerivSpecMechanism
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns }
OriginativeDerivStatus
CanDeriveAnyClass -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
mkNewTypeEqn :: Bool
-> DerivInstTys -> DerivM EarlyDerivSpec
mkNewTypeEqn :: Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
newtype_strat dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> ThetaType
dit_cls_tys = ThetaType
cls_tys
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tycon
, dit_rep_tc_args :: DerivInstTys -> ThetaType
dit_rep_tc_args = ThetaType
rep_tc_args })
= do DerivEnv{denv_cls :: DerivEnv -> Class
denv_cls = Class
cls} <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
DynFlags
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let newtype_deriving :: Bool
newtype_deriving = Extension -> DynFlags -> Bool
xopt Extension
LangExt.GeneralizedNewtypeDeriving DynFlags
dflags
deriveAnyClass :: Bool
deriveAnyClass = Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags
bale_out :: DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out = UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith (Bool -> UsingGeneralizedNewtypeDeriving
usingGeneralizedNewtypeDeriving Bool
newtype_deriving)
nt_eta_arity :: Int
nt_eta_arity = TyCon -> Int
newTyConEtadArity TyCon
rep_tycon
rep_inst_ty :: Type
rep_inst_ty = TyCon -> ThetaType -> Type
newTyConInstRhs TyCon
rep_tycon ThetaType
rep_tc_args
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
eta_ok :: Bool
eta_ok = ThetaType
rep_tc_args ThetaType -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
nt_eta_arity
Bool -> ReaderT DerivEnv TcRn ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (ThetaType
cls_tys ThetaType -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (Class -> Int
classArity Class
cls Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
if Bool
newtype_strat
then
if Bool
eta_ok Bool -> Bool -> Bool
&& Bool
newtype_deriving
then DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_inst_ty
else DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (Bool -> DeriveInstanceErrReason
DerivErrCannotEtaReduceEnough Bool
eta_ok)
else
if Bool
might_be_newtype_derivable
Bool -> Bool -> Bool
&& ((Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
deriveAnyClass)
Bool -> Bool -> Bool
|| Class -> Bool
std_class_via_coercible Class
cls)
then DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_inst_ty
else DerivInstTys -> DerivM OriginativeDerivStatus
checkOriginativeSideConditions DerivInstTys
dit DerivM OriginativeDerivStatus
-> (OriginativeDerivStatus -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> ReaderT DerivEnv TcRn EarlyDerivSpec
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
StockClassError DeriveInstanceErrReason
why
| Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool
newtype_deriving
-> DerivInstTys -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_newtype DerivInstTys
dit Type
rep_inst_ty
| Bool
might_be_newtype_derivable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
newtype_deriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out DeriveInstanceErrReason
why
| Bool
otherwise
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out DeriveInstanceErrReason
why
OriginativeDerivStatus
NonDerivableClass
| Bool
newtype_deriving -> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out (Bool -> DeriveInstanceErrReason
DerivErrCannotEtaReduceEnough Bool
eta_ok)
| Bool
otherwise -> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
bale_out DeriveInstanceErrReason
DerivErrNewtypeNonDeriveableClass
OriginativeDerivStatus
CanDeriveAnyClass -> do
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newtype_deriving Bool -> Bool -> Bool
&& Bool
deriveAnyClass) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnosticTc
(TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Class -> TcRnMessage
TcRnDerivingDefaults Class
cls
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock :: DerivInstTys -> StockGenFns -> DerivSpecMechanism
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns }
genInstBinds :: DerivSpec ThetaType
-> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds :: DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds spec :: DerivSpec ThetaType
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
, ds_tys :: forall theta. DerivSpec theta -> ThetaType
ds_tys = ThetaType
inst_tys, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = ThetaType
theta, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas
, ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_standalone_wildcard :: forall theta. DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard })
= DerivSpec ThetaType
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt DerivSpec ThetaType
spec (IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall a b. (a -> b) -> a -> b
$
do (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
meth_binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
meth_sigs, Bag AuxBindSpec
aux_specs, [Name]
unusedNames) <- TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_inst_binds
ClsInst
inst_spec <- DerivSpec ThetaType -> TcM ClsInst
newDerivClsInst DerivSpec ThetaType
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 String
"newder" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
inst_spec)
let inst_info :: InstInfo GhcPs
inst_info =
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 :: LHsBindsLR GhcPs GhcPs
ib_binds = LHsBindsLR GhcPs GhcPs
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
meth_binds
, ib_tyvars :: [Name]
ib_tyvars = (TyVar -> Name) -> [TyVar] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Name
Var.varName [TyVar]
tyvars
, ib_pragmas :: [LSig GhcPs]
ib_pragmas = [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
meth_sigs
, ib_extensions :: [Extension]
ib_extensions = [Extension]
extensions
, ib_derived :: Bool
ib_derived = Bool
True } }
(InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (InstInfo GhcPs
inst_info, Bag AuxBindSpec
aux_specs, [Name]
unusedNames)
where
extensions :: [LangExt.Extension]
extensions :: [Extension]
extensions
| DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism Bool -> Bool -> Bool
|| DerivSpecMechanism -> Bool
isDerivSpecVia DerivSpecMechanism
mechanism
= [
Extension
LangExt.ImpredicativeTypes, Extension
LangExt.RankNTypes
, Extension
LangExt.InstanceSigs
, Extension
LangExt.UnboxedTuples
]
| Bool
otherwise
= []
gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_inst_binds :: TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_inst_binds
= case DerivSpecMechanism
mechanism of
DerivSpecNewtype { dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rhs_ty}
-> Type
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
rhs_ty
DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns =
StockGenFns { stock_gen_binds :: StockGenFns
-> SrcSpan
-> DerivInstTys
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
stock_gen_binds = SrcSpan
-> DerivInstTys
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_fn } }
-> SrcSpan
-> DerivInstTys
-> TcM
(LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_fn SrcSpan
loc DerivInstTys
dit
DerivSpecMechanism
DerivSpecAnyClass
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. Bag a
emptyBag, [], Bag AuxBindSpec
forall a. Bag a
emptyBag, [])
DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty}
-> Type
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
via_ty
gen_newtype_or_via :: Type
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
ty = do
let (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs) = SrcSpan
-> Class
-> [TyVar]
-> ThetaType
-> Type
-> (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])
gen_Newtype_binds SrcSpan
loc Class
clas [TyVar]
tyvars ThetaType
inst_tys Type
ty
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs, Bag AuxBindSpec
forall a. Bag a
emptyBag, [])
genFamInsts :: DerivSpec theta -> TcM [FamInst]
genFamInsts :: DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts spec :: DerivSpec theta
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
, ds_tys :: forall theta. DerivSpec theta -> ThetaType
ds_tys = ThetaType
inst_tys, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc })
= DerivSpec theta
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt DerivSpec theta
spec (IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall a b. (a -> b) -> a -> b
$
case DerivSpecMechanism
mechanism of
DerivSpecNewtype { dsm_newtype_rep_ty :: DerivSpecMechanism -> Type
dsm_newtype_rep_ty = Type
rhs_ty}
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_newtype_or_via Type
rhs_ty
DerivSpecStock { dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: DerivSpecMechanism -> StockGenFns
dsm_stock_gen_fns =
StockGenFns { stock_gen_fam_insts :: StockGenFns
-> SrcSpan
-> DerivInstTys
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
stock_gen_fam_insts = SrcSpan -> DerivInstTys -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_fn } }
-> SrcSpan -> DerivInstTys -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_fn SrcSpan
loc DerivInstTys
dit
DerivSpecMechanism
DerivSpecAnyClass -> do
let mini_env :: VarEnv Type
mini_env = [(TyVar, Type)] -> VarEnv Type
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (Class -> [TyVar]
classTyVars Class
clas [TyVar] -> 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 <-
Bool
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
(String -> SDoc
forall a. Outputable a => a -> SDoc
ppr String
"genFamInsts: bad derived class" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
clas) (IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]])
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall a b. (a -> b) -> a -> b
$
(ClassATItem -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [ClassATItem] -> IOEnv (Env TcGblEnv TcLclEnv) [[FamInst]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan
-> TCvSubst
-> Uses
-> ClassATItem
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
tcATDefault SrcSpan
loc TCvSubst
mini_subst Uses
emptyNameSet)
(Class -> [ClassATItem]
classATItems Class
clas)
[FamInst] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FamInst] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> [FamInst] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall a b. (a -> b) -> a -> b
$ [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
tyfam_insts
DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty}
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_newtype_or_via Type
via_ty
where
gen_newtype_or_via :: Type -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_newtype_or_via Type
ty = SrcSpan
-> Class
-> [TyVar]
-> ThetaType
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_Newtype_fam_insts SrcSpan
loc Class
clas [TyVar]
tyvars ThetaType
inst_tys Type
ty
set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt (DS{ ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_tys :: forall theta. DerivSpec theta -> ThetaType
ds_tys = ThetaType
tys }) =
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 -> ReaderT DerivEnv TcRn ()
doDerivInstErrorChecks1 DerivSpecMechanism
mechanism =
case DerivSpecMechanism
mechanism of
DerivSpecStock{dsm_stock_dit :: DerivSpecMechanism -> DerivInstTys
dsm_stock_dit = DerivInstTys
dit}
-> DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check DerivInstTys
dit
DerivSpecNewtype{dsm_newtype_dit :: DerivSpecMechanism -> DerivInstTys
dsm_newtype_dit = DerivInstTys
dit}
-> do ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check DerivInstTys
dit
DerivSpecAnyClass{}
-> () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DerivSpecVia{}
-> ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
where
data_cons_in_scope_check :: DerivInstTys -> DerivM ()
data_cons_in_scope_check :: DerivInstTys -> ReaderT DerivEnv TcRn ()
data_cons_in_scope_check (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
Bool
standalone <- DerivM Bool
isStandaloneDeriv
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
standalone (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let bale_out :: DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out DeriveInstanceErrReason
msg = do TcRnMessage
err <- DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
msg
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
err
GlobalRdrEnv
rdr_env <- 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 (TyCon -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn TyCon
rep_tc) Bool -> Bool -> Bool
&&
(TyCon -> Bool
isAbstractTyCon TyCon
rep_tc Bool -> Bool -> Bool
||
(Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
not_in_scope [Name]
data_con_names)
not_in_scope :: Name -> Bool
not_in_scope Name
dc = Maybe GlobalRdrElt -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc)
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrEnv -> TyCon -> TcRn ()
addUsedDataCons GlobalRdrEnv
rdr_env TyCon
rep_tc
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
hidden_data_cons) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out (DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ())
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> DeriveInstanceErrReason
DerivErrDataConsNotAllInScope TyCon
tc
atf_coerce_based_error_checks :: DerivM ()
atf_coerce_based_error_checks :: ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks = do
Class
cls <- (DerivEnv -> Class) -> ReaderT DerivEnv TcRn Class
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks DerivEnv -> Class
denv_cls
let bale_out :: DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out DeriveInstanceErrReason
msg = do TcRnMessage
err <- DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
msg
TcRn () -> ReaderT DerivEnv TcRn ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
err
cls_tyvars :: [TyVar]
cls_tyvars = Class -> [TyVar]
classTyVars Class
cls
ats_look_sensible :: Bool
ats_look_sensible
=
Bool
no_adfs
Bool -> Bool -> Bool
&& Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyCon
at_without_last_cls_tv
Bool -> Bool -> Bool
&& Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TyCon
at_last_cls_tv_in_kinds
([TyCon]
adf_tcs, [TyCon]
atf_tcs) = (TyCon -> Bool) -> [TyCon] -> ([TyCon], [TyCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyCon -> Bool
isDataFamilyTyCon [TyCon]
at_tcs
no_adfs :: Bool
no_adfs = [TyCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCon]
adf_tcs
at_without_last_cls_tv :: Maybe TyCon
at_without_last_cls_tv
= (TyCon -> Bool) -> [TyCon] -> Maybe TyCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TyCon
tc -> TyVar
last_cls_tv TyVar -> [TyVar] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TyCon -> [TyVar]
tyConTyVars TyCon
tc) [TyCon]
atf_tcs
at_last_cls_tv_in_kinds :: Maybe TyCon
at_last_cls_tv_in_kinds
= (TyCon -> Bool) -> [TyCon] -> Maybe TyCon
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TyCon
tc -> (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Bool
at_last_cls_tv_in_kind (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind)
(TyCon -> [TyVar]
tyConTyVars TyCon
tc)
Bool -> Bool -> Bool
|| Type -> Bool
at_last_cls_tv_in_kind (TyCon -> Type
tyConResKind TyCon
tc)) [TyCon]
atf_tcs
at_last_cls_tv_in_kind :: Type -> Bool
at_last_cls_tv_in_kind Type
kind
= TyVar
last_cls_tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
kind
at_tcs :: [TyCon]
at_tcs = Class -> [TyCon]
classATs Class
cls
last_cls_tv :: TyVar
last_cls_tv = Bool -> ([TyVar] -> TyVar) -> [TyVar] -> TyVar
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [TyVar]
cls_tyvars )
[TyVar] -> TyVar
forall a. [a] -> a
last [TyVar]
cls_tyvars
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ats_look_sensible (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
bale_out (HasAssociatedDataFamInsts
-> AssociatedTyLastVarInKind
-> AssociatedTyNotParamOverLastTyVar
-> DeriveInstanceErrReason
DerivErrHasAssociatedDatatypes
(Bool -> HasAssociatedDataFamInsts
hasAssociatedDataFamInsts (Bool -> Bool
not Bool
no_adfs))
(Maybe TyCon -> AssociatedTyLastVarInKind
associatedTyLastVarInKind Maybe TyCon
at_last_cls_tv_in_kinds)
(Maybe TyCon -> AssociatedTyNotParamOverLastTyVar
associatedTyNotParamOverLastTyVar Maybe TyCon
at_without_last_cls_tv)
)
doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 :: Class
-> ClsInst
-> ThetaType
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
clas_inst ThetaType
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
= do { String -> SDoc -> TcRn ()
traceTc String
"doDerivInstErrorChecks2" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
clas_inst)
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool
xpartial_sigs <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
; Bool
wpartial_sigs <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
; case Maybe SrcSpan
wildcard of
Maybe SrcSpan
Nothing -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just SrcSpan
span -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
span (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let suggParSigs :: SuggestPartialTypeSignatures
suggParSigs = Bool -> SuggestPartialTypeSignatures
suggestPartialTypeSignatures Bool
xpartial_sigs
let dia :: TcRnMessage
dia = SuggestPartialTypeSignatures -> ThetaType -> TcRnMessage
TcRnPartialTypeSignatures SuggestPartialTypeSignatures
suggParSigs ThetaType
theta
Bool -> TcRnMessage -> TcRn ()
checkTc Bool
xpartial_sigs TcRnMessage
dia
Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
wpartial_sigs TcRnMessage
dia
; 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 -> TcRnMessage -> TcRn ()
failIfTc (DynFlags -> Bool
safeLanguageOn DynFlags
dflags)
(Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
clas ThetaType
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
DeriveInstanceErrReason
DerivErrSafeHaskellGenericInst)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeInferOn DynFlags
dflags) (Messages TcRnMessage -> TcRn ()
recordUnsafeInfer Messages TcRnMessage
forall e. Messages e
emptyMessages) } }
where
exotic_mechanism :: Bool
exotic_mechanism = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DerivSpecMechanism -> Bool
isDerivSpecStock DerivSpecMechanism
mechanism
derivingThingFailWith :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> DerivM a
derivingThingFailWith :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
msg = do
TcRnMessage
err <- UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrM UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
msg
IOEnv (Env TcGblEnv TcLclEnv) a -> DerivM a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) a -> DerivM a)
-> IOEnv (Env TcGblEnv TcLclEnv) a -> DerivM a
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) a
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
err
derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> DerivM TcRnMessage
derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrM UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why
= do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> ThetaType
denv_inst_tys = ThetaType
cls_args
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
TcRnMessage -> DerivM TcRnMessage
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcRnMessage -> DerivM TcRnMessage)
-> TcRnMessage -> DerivM TcRnMessage
forall a b. (a -> b) -> a -> b
$ Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
cls_args Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why
derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
why
= do DerivEnv { denv_cls :: DerivEnv -> Class
denv_cls = Class
cls
, denv_inst_tys :: DerivEnv -> ThetaType
denv_inst_tys = ThetaType
cls_args
, denv_strat :: DerivEnv -> Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
TcRnMessage -> DerivM TcRnMessage
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TcRnMessage -> DerivM TcRnMessage)
-> TcRnMessage -> DerivM TcRnMessage
forall a b. (a -> b) -> a -> b
$ Class
-> ThetaType
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls ThetaType
cls_args Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why
where
newtype_deriving :: UsingGeneralizedNewtypeDeriving
newtype_deriving :: UsingGeneralizedNewtypeDeriving
newtype_deriving
= if DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism then UsingGeneralizedNewtypeDeriving
YesGeneralizedNewtypeDeriving
else UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
ty = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the stand-alone deriving instance for")
Int
2 (SDoc -> SDoc
quotes (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty))