{-# 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( 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.Unit.Module.Warnings
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.Hint (AssumedDerivingStrategy(..))
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.Logger
import GHC.Data.Bag
import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.BooleanFormula ( isUnsatisfied )
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List (partition, find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)
| GivenTheta (DerivSpec ThetaType)
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec :: [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta DerivSpec ThetaSpec
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec ThetaSpec]
is, [DerivSpec [Type]]
gs) -> (DerivSpec ThetaSpec
spec DerivSpec ThetaSpec
-> [DerivSpec ThetaSpec] -> [DerivSpec ThetaSpec]
forall a. a -> [a] -> [a]
: [DerivSpec ThetaSpec]
is, [DerivSpec [Type]]
gs)
splitEarlyDerivSpec (GivenTheta DerivSpec [Type]
spec : [EarlyDerivSpec]
specs) =
case [EarlyDerivSpec] -> ([DerivSpec ThetaSpec], [DerivSpec [Type]])
splitEarlyDerivSpec [EarlyDerivSpec]
specs of ([DerivSpec ThetaSpec]
is, [DerivSpec [Type]]
gs) -> ([DerivSpec ThetaSpec]
is, DerivSpec [Type]
spec DerivSpec [Type] -> [DerivSpec [Type]] -> [DerivSpec [Type]]
forall a. a -> [a] -> [a]
: [DerivSpec [Type]]
gs)
instance Outputable EarlyDerivSpec where
ppr :: EarlyDerivSpec -> SDoc
ppr (InferTheta DerivSpec ThetaSpec
spec) = DerivSpec ThetaSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec ThetaSpec
spec SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(Infer)"
ppr (GivenTheta DerivSpec [Type]
spec) = DerivSpec [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DerivSpec [Type]
spec SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(Given)"
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 { g <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; return (g, emptyBag, 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 {
early_specs <- [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
; traceTc "tcDeriving" (ppr early_specs)
; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
; famInsts1 <- concatMapM genFamInsts given_specs
; famInsts2 <- concatMapM genFamInsts infer_specs
; let famInsts = [FamInst]
famInsts1 [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
famInsts2
; logger <- getLogger
; tcExtendLocalFamInstEnv famInsts $
do { given_inst_binds <- mapM genInstBinds given_specs
; let 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
; final_infer_specs <-
extendLocalInstEnv (map iSpec given_inst_infos) $
simplifyInstanceContexts infer_specs
; infer_inst_binds <- mapM genInstBinds final_infer_specs
; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)
; loc <- getSrcSpanM
; let aux_binds = SrcSpan -> Bag AuxBindSpec -> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds SrcSpan
loc ([Bag AuxBindSpec] -> Bag AuxBindSpec
forall a. [Bag a] -> Bag a
unionManyBags [Bag AuxBindSpec]
aux_specs)
; let infer_inst_infos = ((InstInfo GhcPs, 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]
given_inst_infos [InstInfo GhcPs] -> [InstInfo GhcPs] -> [InstInfo GhcPs]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcPs]
infer_inst_infos
; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds
; unless (isEmptyBag inst_info) $
liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances"
FormatHaskell
(ddump_deriving inst_info rn_aux_binds famInsts))
; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
getGblEnv
; let 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)
; return (addTcgDUs gbl_env all_dus, inst_info, 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
forall doc. IsLine doc => String -> doc
text String
"Derived class instances:")
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((InstInfo GhcRn -> SDoc) -> [InstInfo GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcRn
i -> InstInfo GhcRn -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcRn
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"") (Bag (InstInfo GhcRn) -> [InstInfo GhcRn]
forall a. Bag a -> [a]
bagToList Bag (InstInfo GhcRn)
inst_infos))
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsValBinds GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsValBinds GhcRn
extra_binds)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> SDoc -> SDoc
hangP (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Derived type family instances:")
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((FamInst -> SDoc) -> [FamInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> SDoc
pprRepTy [FamInst]
famInsts))
hangP :: SDoc -> SDoc -> SDoc
hangP SDoc
s SDoc
x = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
s Int
2 SDoc
x
pprRepTy :: FamInst -> SDoc
pprRepTy :: FamInst -> SDoc
pprRepTy fi :: FamInst
fi@(FamInst { fi_tys :: FamInst -> [Type]
fi_tys = [Type]
lhs })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp (FamInst -> TyCon
famInstTyCon FamInst
fi) [Type]
lhs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs
where rhs :: Type
rhs = FamInst -> Type
famInstRHS FamInst
fi
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv [InstInfo GhcPs]
inst_infos Bag (LHsBind GhcPs, LSig GhcPs)
bagBinds
= TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a. TcRn a -> TcRn a
discardWarnings (TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses))
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
forall a b. (a -> b) -> a -> b
$
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.TypeAbstractions (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
forall doc. IsDoc doc => [doc] -> doc
vcat ((InstInfo GhcPs -> SDoc) -> [InstInfo GhcPs] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\InstInfo GhcPs
i -> InstInfo GhcPs -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo GhcPs
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"") [InstInfo GhcPs]
inst_infos))
; let (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
aux_binds, Bag (GenLocated SrcSpanAnnA (Sig GhcPs))
aux_sigs) = Bag
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
Bag (GenLocated SrcSpanAnnA (Sig GhcPs)))
forall a b. Bag (a, b) -> (Bag a, Bag b)
unzipBag Bag (LHsBind GhcPs, LSig GhcPs)
Bag
(GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
GenLocated SrcSpanAnnA (Sig GhcPs))
bagBinds
aux_val_binds :: HsValBindsLR GhcPs GhcPs
aux_val_binds = XValBinds GhcPs GhcPs
-> LHsBindsLR GhcPs GhcPs
-> [LSig GhcPs]
-> HsValBindsLR GhcPs GhcPs
forall idL idR.
XValBinds idL idR
-> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR
ValBinds XValBinds GhcPs GhcPs
AnnSortKey BindTag
forall tag. AnnSortKey tag
NoAnnSortKey (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
forall a. Bag a -> [a]
bagToList 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)
; (bndrs, rn_aux_lhs) <- MiniFixityEnv
-> HsValBindsLR GhcPs GhcPs
-> RnM ([Name], HsValBindsLR GhcRn GhcPs)
rnLocalValBindsLHS MiniFixityEnv
emptyMiniFixityEnv HsValBindsLR GhcPs GhcPs
aux_val_binds
; bindLocalNames bndrs $
do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
; return (listToBag rn_inst_infos, rn_aux,
dus_aux `plusDU` usesOnly (plusFVs 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 { (rn_binds, rn_sigs, 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 { ib_binds :: LHsBinds GhcRn
ib_binds = LHsBinds GhcRn
[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 }
; return (inst_info { iBinds = binds' }, fvs) }
mechanismToAssumedStrategy :: DerivSpecMechanism -> Maybe AssumedDerivingStrategy
mechanismToAssumedStrategy :: DerivSpecMechanism -> Maybe AssumedDerivingStrategy
mechanismToAssumedStrategy = \case
DerivSpecStock{} -> AssumedDerivingStrategy -> Maybe AssumedDerivingStrategy
forall a. a -> Maybe a
Just AssumedDerivingStrategy
AssumedStockStrategy
DerivSpecAnyClass{} -> AssumedDerivingStrategy -> Maybe AssumedDerivingStrategy
forall a. a -> Maybe a
Just AssumedDerivingStrategy
AssumedAnyclassStrategy
DerivSpecNewtype{} -> AssumedDerivingStrategy -> Maybe AssumedDerivingStrategy
forall a. a -> Maybe a
Just AssumedDerivingStrategy
AssumedNewtypeStrategy
DerivSpecVia{} -> Maybe AssumedDerivingStrategy
forall a. Maybe a
Nothing
warnNoDerivingClauseStrategy
:: Maybe (LDerivStrategy GhcTc)
-> [(LHsSigType GhcRn, EarlyDerivSpec)]
-> TcM ()
warnNoDerivingClauseStrategy :: Maybe (LDerivStrategy GhcTc)
-> [(LHsSigType GhcRn, EarlyDerivSpec)] -> TcRn ()
warnNoDerivingClauseStrategy Just{} [(LHsSigType GhcRn, EarlyDerivSpec)]
_early_deriv_specs = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnNoDerivingClauseStrategy Maybe (LDerivStrategy GhcTc)
Nothing [(LHsSigType GhcRn, EarlyDerivSpec)]
early_deriv_specs = do
let all_assumed_strategies :: Map AssumedDerivingStrategy [LHsSigType GhcRn]
all_assumed_strategies :: Map AssumedDerivingStrategy [LHsSigType GhcRn]
all_assumed_strategies =
([GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)])
-> [Map
AssumedDerivingStrategy [GenLocated SrcSpanAnnA (HsSigType GhcRn)]]
-> Map
AssumedDerivingStrategy [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
forall a. [a] -> [a] -> [a]
(++) (((GenLocated SrcSpanAnnA (HsSigType GhcRn), EarlyDerivSpec)
-> Map
AssumedDerivingStrategy [GenLocated SrcSpanAnnA (HsSigType GhcRn)])
-> [(GenLocated SrcSpanAnnA (HsSigType GhcRn), EarlyDerivSpec)]
-> [Map
AssumedDerivingStrategy [GenLocated SrcSpanAnnA (HsSigType GhcRn)]]
forall a b. (a -> b) -> [a] -> [b]
map (LHsSigType GhcRn, EarlyDerivSpec)
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
(GenLocated SrcSpanAnnA (HsSigType GhcRn), EarlyDerivSpec)
-> Map
AssumedDerivingStrategy [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
early_deriv_spec_to_assumed_strategies [(LHsSigType GhcRn, EarlyDerivSpec)]
[(GenLocated SrcSpanAnnA (HsSigType GhcRn), EarlyDerivSpec)]
early_deriv_specs)
dyn_flags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
addDiagnosticTc $
TcRnNoDerivStratSpecified (xopt LangExt.DerivingStrategies dyn_flags) $
TcRnNoDerivingClauseStrategySpecified all_assumed_strategies
where
deriv_spec_to_assumed_strategy :: LHsSigType GhcRn
-> DerivSpec theta
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
deriv_spec_to_assumed_strategy :: forall theta.
LHsSigType GhcRn
-> DerivSpec theta
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
deriv_spec_to_assumed_strategy LHsSigType GhcRn
deriv_head DerivSpec theta
deriv_spec =
[(AssumedDerivingStrategy,
[GenLocated SrcSpanAnnA (HsSigType GhcRn)])]
-> Map
AssumedDerivingStrategy [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (AssumedDerivingStrategy
strat, [LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_head])
| AssumedDerivingStrategy
strat <- Maybe AssumedDerivingStrategy -> [AssumedDerivingStrategy]
forall a. Maybe a -> [a]
maybeToList (Maybe AssumedDerivingStrategy -> [AssumedDerivingStrategy])
-> Maybe AssumedDerivingStrategy -> [AssumedDerivingStrategy]
forall a b. (a -> b) -> a -> b
$ DerivSpecMechanism -> Maybe AssumedDerivingStrategy
mechanismToAssumedStrategy (DerivSpec theta -> DerivSpecMechanism
forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism DerivSpec theta
deriv_spec)
]
early_deriv_spec_to_assumed_strategies :: (LHsSigType GhcRn, EarlyDerivSpec)
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
early_deriv_spec_to_assumed_strategies :: (LHsSigType GhcRn, EarlyDerivSpec)
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
early_deriv_spec_to_assumed_strategies (LHsSigType GhcRn
deriv_head, InferTheta DerivSpec ThetaSpec
deriv_spec) =
LHsSigType GhcRn
-> DerivSpec ThetaSpec
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
forall theta.
LHsSigType GhcRn
-> DerivSpec theta
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
deriv_spec_to_assumed_strategy LHsSigType GhcRn
deriv_head DerivSpec ThetaSpec
deriv_spec
early_deriv_spec_to_assumed_strategies (LHsSigType GhcRn
deriv_head, GivenTheta DerivSpec [Type]
deriv_spec) =
LHsSigType GhcRn
-> DerivSpec [Type]
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
forall theta.
LHsSigType GhcRn
-> DerivSpec theta
-> Map AssumedDerivingStrategy [LHsSigType GhcRn]
deriv_spec_to_assumed_strategy LHsSigType GhcRn
deriv_head DerivSpec [Type]
deriv_spec
warnNoStandaloneDerivingStrategy
:: Maybe (LDerivStrategy GhcTc)
-> LHsSigWcType GhcRn
-> EarlyDerivSpec
-> TcM ()
warnNoStandaloneDerivingStrategy :: Maybe (LDerivStrategy GhcTc)
-> LHsSigWcType GhcRn -> EarlyDerivSpec -> TcRn ()
warnNoStandaloneDerivingStrategy Just{} LHsSigWcType GhcRn
_deriv_ty EarlyDerivSpec
_early_deriv_spec = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnNoStandaloneDerivingStrategy Maybe (LDerivStrategy GhcTc)
Nothing LHsSigWcType GhcRn
deriv_ty EarlyDerivSpec
early_deriv_spec =
case DerivSpecMechanism -> Maybe AssumedDerivingStrategy
mechanismToAssumedStrategy (DerivSpecMechanism -> Maybe AssumedDerivingStrategy)
-> DerivSpecMechanism -> Maybe AssumedDerivingStrategy
forall a b. (a -> b) -> a -> b
$ EarlyDerivSpec -> DerivSpecMechanism
early_deriv_spec_mechanism EarlyDerivSpec
early_deriv_spec of
Maybe AssumedDerivingStrategy
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just AssumedDerivingStrategy
assumed_strategy -> do
dyn_flags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
addDiagnosticTc $
TcRnNoDerivStratSpecified (xopt LangExt.DerivingStrategies dyn_flags) $
TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_ty
where
early_deriv_spec_mechanism :: EarlyDerivSpec -> DerivSpecMechanism
early_deriv_spec_mechanism :: EarlyDerivSpec -> DerivSpecMechanism
early_deriv_spec_mechanism (InferTheta DerivSpec ThetaSpec
deriv_spec) = DerivSpec ThetaSpec -> DerivSpecMechanism
forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism DerivSpec ThetaSpec
deriv_spec
early_deriv_spec_mechanism (GivenTheta DerivSpec [Type]
deriv_spec) = DerivSpec [Type] -> DerivSpecMechanism
forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism DerivSpec [Type]
deriv_spec
makeDerivSpecs :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM [EarlyDerivSpec]
makeDerivSpecs :: [DerivInfo] -> [LDerivDecl GhcRn] -> TcM [EarlyDerivSpec]
makeDerivSpecs [DerivInfo]
deriv_infos [LDerivDecl GhcRn]
deriv_decls
= do { eqns1 <- [TcM [EarlyDerivSpec]]
-> IOEnv (Env TcGblEnv TcLclEnv) [[EarlyDerivSpec]]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
[ TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> LocatedC [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
dcs (LDerivClauseTys GhcRn -> LocatedC [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 EpAnnCO
_ (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 EpAnnCO (HsDerivingClause GhcRn)]
clauses
]
; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
; return $ concat eqns1 ++ catMaybes eqns2 }
where
deriv_clause_preds :: LDerivClauseTys GhcRn -> LocatedC [LHsSigType GhcRn]
deriv_clause_preds :: LDerivClauseTys GhcRn -> LocatedC [LHsSigType GhcRn]
deriv_clause_preds (L SrcSpanAnnC
loc DerivClauseTys GhcRn
dct) = case DerivClauseTys GhcRn
dct of
DctSingle XDctSingle GhcRn
_ LHsSigType GhcRn
ty -> SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
loc [LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ty]
DctMulti XDctMulti GhcRn
_ [LHsSigType GhcRn]
tys -> SrcSpanAnnC
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
-> GenLocated
SrcSpanAnnC [GenLocated SrcSpanAnnA (HsSigType GhcRn)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
loc [LHsSigType GhcRn]
[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
tys
deriveClause :: TyCon
-> [(Name, TcTyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> LocatedC [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause :: TyCon
-> [(Name, TyVar)]
-> Maybe (LDerivStrategy GhcRn)
-> LocatedC [LHsSigType GhcRn]
-> SDoc
-> TcM [EarlyDerivSpec]
deriveClause TyCon
rep_tc [(Name, TyVar)]
scoped_tvs Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat (L SrcSpanAnnC
loc [LHsSigType GhcRn]
deriv_preds) SDoc
err_ctxt
= SrcSpanAnnC -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnC
loc (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec])
-> TcM [EarlyDerivSpec] -> TcM [EarlyDerivSpec]
forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcRn ()
traceTc String
"deriveClause" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"scoped_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
scoped_tvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tys" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (GenLocated EpAnnCO (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated EpAnnCO (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
(mb_lderiv_strat', via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
earlyDerivSpecs <- tcExtendTyVarEnv via_tvs $
mapMaybeM
(\GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred ->
do maybe_early_deriv_spec <- TyCon
-> [Type]
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc [Type]
tys Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc))
mb_lderiv_strat' [TyVar]
via_tvs LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred
pure $ fmap (deriv_pred,) maybe_early_deriv_spec)
deriv_preds
warnNoDerivingClauseStrategy mb_lderiv_strat' earlyDerivSpecs
return (snd <$> earlyDerivSpecs)
where
tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
rep_tc
(TyCon
tc, [Type]
tys) = case TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)
tyConFamInstSig_maybe TyCon
rep_tc of
Just (TyCon
fam_tc, [Type]
pats, CoAxiom Unbranched
_) -> (TyCon
fam_tc, [Type]
pats)
Maybe (TyCon, [Type], CoAxiom Unbranched)
_ -> (TyCon
rep_tc, [TyVar] -> [Type]
mkTyVarTys [TyVar]
tvs)
derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]
-> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)
derivePred :: TyCon
-> [Type]
-> Maybe (LDerivStrategy GhcTc)
-> [TyVar]
-> LHsSigType GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
derivePred TyCon
tc [Type]
tys Maybe (LDerivStrategy GhcTc)
mb_lderiv_strat [TyVar]
via_tvs LHsSigType GhcRn
deriv_pred =
IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (Maybe EarlyDerivSpec
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe EarlyDerivSpec
forall a. Maybe a
Nothing) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$ do
String -> SDoc -> TcRn ()
traceTc String
"derivePred" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tys" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"deriv_pred" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
deriv_pred
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"mb_lderiv_strat" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc))
mb_lderiv_strat
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
via_tvs ]
(cls_tvs, cls, cls_tys, cls_arg_kinds) <- LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Type])
tcHsDeriv LHsSigType GhcRn
deriv_pred
when (cls_arg_kinds `lengthIsNot` 1) $
failWithTc (TcRnNonUnaryTypeclassConstraint DerivClauseCtxt deriv_pred)
let [cls_arg_kind] = cls_arg_kinds
mb_deriv_strat = (GenLocated EpAnnCO (DerivStrategy GhcTc) -> DerivStrategy GhcTc)
-> Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated EpAnnCO (DerivStrategy GhcTc) -> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (LDerivStrategy GhcTc)
Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc))
mb_lderiv_strat
if (className cls == typeableClassName)
then do warnUselessTypeable
return Nothing
else let deriv_tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs in
Just <$> deriveTyData tc tys mb_deriv_strat
deriv_tvs cls cls_tys cls_arg_kind
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
deriveStandalone :: LDerivDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
deriveStandalone (L SrcSpanAnnA
loc (DerivDecl (Maybe (GenLocated SrcSpanAnnP (WarningTxt GhcRn))
warn, AnnDerivDecl
_) LHsSigWcType GhcRn
deriv_ty Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat Maybe (XRec GhcRn OverlapMode)
overlap_mode))
= SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
deriv_ty) (IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec))
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe EarlyDerivSpec)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Standalone deriving decl for" (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
deriv_ty)
; let ctxt :: UserTypeCtxt
ctxt = Bool -> UserTypeCtxt
GHC.Tc.Types.Origin.InstDeclCtxt Bool
True
; String -> SDoc -> TcRn ()
traceTc String
"Deriving strategy (standalone deriving)" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Maybe (GenLocated EpAnnCO (DerivStrategy GhcRn)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LDerivStrategy GhcRn)
Maybe (GenLocated EpAnnCO (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]
; (mb_lderiv_strat, via_tvs) <- Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lderiv_strat
; traceTc "Deriving strategy (standalone deriving) 2" $
vcat [ppr mb_lderiv_strat, ppr via_tvs]
; (cls_tvs, deriv_ctxt, cls, inst_tys)
<- tcExtendTyVarEnv via_tvs $
tcStandaloneDerivInstType ctxt deriv_ty
; let mb_deriv_strat = (GenLocated EpAnnCO (DerivStrategy GhcTc) -> DerivStrategy GhcTc)
-> Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc))
-> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated EpAnnCO (DerivStrategy GhcTc) -> DerivStrategy GhcTc
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated EpAnnCO (DerivStrategy GhcTc))
mb_lderiv_strat
tvs = [TyVar]
via_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
cls_tvs
; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <-
case mb_deriv_strat of
Just (ViaStrategy XViaStrategy GhcTc
via_ty)
| Just Type
inst_ty <- [Type] -> Maybe Type
forall a. [a] -> Maybe a
lastMaybe [Type]
inst_tys
-> do
let via_kind :: Type
via_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind XViaStrategy GhcTc
Type
via_ty
inst_ty_kind :: Type
inst_ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
inst_ty
mb_match :: Maybe Subst
mb_match = Type -> Type -> Maybe Subst
tcUnifyTy Type
inst_ty_kind Type
via_kind
Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
mb_match)
(Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type -> DeriveInstanceErrReason
DerivErrDerivingViaWrongKind Type
inst_ty_kind XViaStrategy GhcTc
Type
via_ty Type
via_kind)
let Just Subst
kind_subst = Maybe Subst
mb_match
ki_subst_range :: VarSet
ki_subst_range = Subst -> VarSet
getSubstRangeTyCoFVs Subst
kind_subst
unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> Subst -> Bool
`notElemSubst` Subst
kind_subst
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
[TyVar]
tvs
(Subst
subst, [TyVar]
_) = HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar])
Subst -> [TyVar] -> (Subst, [TyVar])
substTyVarBndrs Subst
kind_subst [TyVar]
unmapped_tkvs
(DerivContext
final_deriv_ctxt, [Type]
final_deriv_ctxt_tys)
= case DerivContext
deriv_ctxt of
InferContext Maybe SrcSpan
wc -> (Maybe SrcSpan -> DerivContext
InferContext Maybe SrcSpan
wc, [])
SupplyContext [Type]
theta ->
let final_theta :: [Type]
final_theta = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTheta Subst
subst [Type]
theta
in ([Type] -> DerivContext
SupplyContext [Type]
final_theta, [Type]
final_theta)
final_inst_tys :: [Type]
final_inst_tys = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
inst_tys
final_via_ty :: Type
final_via_ty = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst XViaStrategy GhcTc
Type
via_ty
final_tvs :: [TyVar]
final_tvs = [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped ([Type] -> [TyVar]) -> [Type] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
[Type]
final_deriv_ctxt_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
final_inst_tys
[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
final_via_ty]
([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [TyVar]
final_tvs, DerivContext
final_deriv_ctxt, [Type]
final_inst_tys
, DerivStrategy GhcTc -> Maybe (DerivStrategy GhcTc)
forall a. a -> Maybe a
Just (XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcTc
Type
final_via_ty) )
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], DerivContext, [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, DerivContext
deriv_ctxt, [Type]
inst_tys, Maybe (DerivStrategy GhcTc)
mb_deriv_strat)
; traceTc "Standalone deriving;" $ vcat
[ text "tvs':" <+> ppr tvs'
, text "mb_deriv_strat':" <+> ppr mb_deriv_strat'
, text "deriv_ctxt':" <+> ppr deriv_ctxt'
, text "cls:" <+> ppr cls
, text "inst_tys':" <+> ppr inst_tys' ]
; if className cls == typeableClassName
then do warnUselessTypeable
return Nothing
else do early_deriv_spec <-
mkEqnHelp (fmap unLoc overlap_mode)
tvs' cls inst_tys'
deriv_ctxt' mb_deriv_strat'
(fmap unLoc warn)
warnNoStandaloneDerivingStrategy
mb_lderiv_strat
deriv_ty
early_deriv_spec
pure (Just early_deriv_spec) }
tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType :: UserTypeCtxt
-> LHsSigWcType GhcRn -> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType UserTypeCtxt
ctxt
(HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = deriv_ty :: LHsSigType GhcRn
deriv_ty@(L SrcSpanAnnA
loc (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
deriv_ty_body }))})
| (Maybe (LHsContext GhcRn)
theta, LHsType GhcRn
rho) <- LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
deriv_ty_body
, [LHsType GhcRn
wc_pred] <- Maybe (LHsContext GhcRn) -> [LHsType GhcRn]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
theta
, L SrcSpanAnnA
wc_span (HsWildCardTy XWildCardTy GhcRn
_) <- LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens LHsType GhcRn
wc_pred
= do dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt (LHsSigType GhcRn -> TcM Type) -> LHsSigType GhcRn -> TcM Type
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> HsSigType GhcRn -> GenLocated SrcSpanAnnA (HsSigType GhcRn)
forall a b. (a -> b) -> a -> b
$
HsSig { sig_ext :: XHsSig GhcRn
sig_ext = XHsSig GhcRn
NoExtField
noExtField
, sig_bndrs :: HsOuterSigTyVarBndrs GhcRn
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs
, sig_body :: LHsType GhcRn
sig_body = LHsType GhcRn
rho }
let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys)
| Bool
otherwise
= do dfun_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
ctxt LHsSigType GhcRn
deriv_ty
let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, SupplyContext theta, cls, 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
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> [TyVar]
-> Class
-> [Type]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
deriveTyData TyCon
tc [Type]
tc_args Maybe (DerivStrategy GhcTc)
mb_deriv_strat [TyVar]
deriv_tvs Class
cls [Type]
cls_tys Type
cls_arg_kind
= do {
let ([Scaled Type]
arg_kinds, Type
_) = Type -> ([Scaled Type], Type)
splitFunTys Type
cls_arg_kind
n_args_to_drop :: Int
n_args_to_drop = [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
arg_kinds
n_args_to_keep :: Int
n_args_to_keep = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tc_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_args_to_drop
([Type]
tc_args_to_keep, [Type]
args_to_drop)
= Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_args_to_keep [Type]
tc_args
inst_ty_kind :: Type
inst_ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args_to_keep)
mb_match :: Maybe Subst
mb_match = Type -> Type -> Maybe Subst
tcUnifyTy Type
inst_ty_kind Type
cls_arg_kind
enough_args :: Bool
enough_args = Int
n_args_to_keep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
; String -> SDoc -> TcRn ()
traceTc String
"deriveTyData" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"class:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind (Class -> TyCon
classTyCon Class
cls))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls_tys:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tycon:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls_arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args_to_keep) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty_kind
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cls_arg_kind:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cls_arg_kind ]
; Bool -> TcRnMessage -> TcRn ()
checkTc (Bool
enough_args Bool -> Bool -> Bool
&& Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
mb_match)
(Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
TyCon -> Type -> Int -> DeriveInstanceErrReason
DerivErrNotWellKinded TyCon
tc Type
cls_arg_kind Int
n_args_to_keep)
; let
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys = (DerivStrategy GhcTc -> [Type])
-> Maybe (DerivStrategy GhcTc) -> [Type]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Type]
-> (XViaStrategy GhcTc -> [Type]) -> DerivStrategy GhcTc -> [Type]
forall p (pass :: Pass) r.
(p ~ GhcPass pass) =>
r -> (XViaStrategy p -> r) -> DerivStrategy p -> r
foldDerivStrategy [] (XViaStrategy GhcTc -> [XViaStrategy GhcTc] -> [XViaStrategy GhcTc]
forall a. a -> [a] -> [a]
:[]))
propagate_subst :: Subst
-> [TyVar]
-> [Type]
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
propagate_subst Subst
kind_subst [TyVar]
tkvs' [Type]
cls_tys' [Type]
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
= ([TyVar]
final_tkvs, [Type]
final_cls_tys, [Type]
final_tc_args, Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat)
where
ki_subst_range :: VarSet
ki_subst_range = Subst -> VarSet
getSubstRangeTyCoFVs Subst
kind_subst
unmapped_tkvs :: [TyVar]
unmapped_tkvs = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVar
v -> TyVar
v TyVar -> Subst -> Bool
`notElemSubst` Subst
kind_subst
Bool -> Bool -> Bool
&& Bool -> Bool
not (TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
ki_subst_range))
[TyVar]
tkvs'
(Subst
subst, [TyVar]
_) = HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar])
Subst -> [TyVar] -> (Subst, [TyVar])
substTyVarBndrs Subst
kind_subst [TyVar]
unmapped_tkvs
final_tc_args :: [Type]
final_tc_args = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
tc_args'
final_cls_tys :: [Type]
final_cls_tys = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
subst [Type]
cls_tys'
final_mb_deriv_strat :: Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst))
Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
final_tkvs :: [TyVar]
final_tkvs = [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped ([Type] -> [TyVar]) -> [Type] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
[Type]
final_cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
final_tc_args
[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys Maybe (DerivStrategy GhcTc)
final_mb_deriv_strat
; let tkvs :: [TyVar]
tkvs = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ FV -> [TyVar]
fvVarList (FV -> [TyVar]) -> FV -> [TyVar]
forall a b. (a -> b) -> a -> b
$
FV -> FV -> FV
unionFV ([Type] -> FV
tyCoFVsOfTypes [Type]
tc_args_to_keep)
([TyVar] -> FV
FV.mkFVs [TyVar]
deriv_tvs)
Just Subst
kind_subst = Maybe Subst
mb_match
([TyVar]
tkvs', [Type]
cls_tys', [Type]
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
= Subst
-> [TyVar]
-> [Type]
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
propagate_subst Subst
kind_subst [TyVar]
tkvs [Type]
cls_tys
[Type]
tc_args_to_keep Maybe (DerivStrategy GhcTc)
mb_deriv_strat
; (final_tkvs, final_cls_tys, final_tc_args, 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
typeKind XViaStrategy GhcTc
Type
via_ty
inst_ty_kind :: Type
inst_ty_kind
= HasDebugCallStack => Type -> Type
Type -> Type
typeKind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args')
via_match :: Maybe Subst
via_match = Type -> Type -> Maybe Subst
tcUnifyTy Type
inst_ty_kind Type
via_kind
Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
via_match)
(Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
forall a. Monoid a => a
mempty Maybe (DerivStrategy GhcTc)
forall a. Maybe a
Nothing UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type -> DeriveInstanceErrReason
DerivErrDerivingViaWrongKind Type
inst_ty_kind XViaStrategy GhcTc
Type
via_ty Type
via_kind)
let Just Subst
via_subst = Maybe Subst
via_match
([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc)))
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
forall a b. (a -> b) -> a -> b
$ Subst
-> [TyVar]
-> [Type]
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
propagate_subst Subst
via_subst [TyVar]
tkvs' [Type]
cls_tys'
[Type]
tc_args' Maybe (DerivStrategy GhcTc)
mb_deriv_strat'
Maybe (DerivStrategy GhcTc)
_ -> ([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
-> IOEnv
(Env TcGblEnv TcLclEnv)
([TyVar], [Type], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tkvs', [Type]
cls_tys', [Type]
tc_args', Maybe (DerivStrategy GhcTc)
mb_deriv_strat')
; traceTc "deriveTyData 1" $ vcat
[ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args
, pprTyVars (tyCoVarsOfTypesList tc_args)
, ppr n_args_to_keep, ppr n_args_to_drop
, ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
, ppr final_tc_args, ppr final_cls_tys ]
; traceTc "deriveTyData 2" $ vcat
[ ppr final_tkvs ]
; let final_tc_app = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
final_tc_args
final_cls_args = [Type]
final_cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
final_tc_app]
; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop)
(TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $
DerivErrNoEtaReduce final_tc_app)
; checkValidInstHead DerivClauseCtxt cls final_cls_args
; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args
(InferContext Nothing) final_mb_deriv_strat
Nothing
; traceTc "deriveTyData 3" (ppr spec)
; return spec }
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> Maybe (WarningTxt GhcRn)
-> TcRn EarlyDerivSpec
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class
-> [Type]
-> DerivContext
-> Maybe (DerivStrategy GhcTc)
-> Maybe (WarningTxt GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) EarlyDerivSpec
mkEqnHelp Maybe OverlapMode
overlap_mode [TyVar]
tvs Class
cls [Type]
cls_args DerivContext
deriv_ctxt Maybe (DerivStrategy GhcTc)
deriv_strat Maybe (WarningTxt GhcRn)
warn = do
is_boot <- TcRn Bool
tcIsHsBootOrSig
when is_boot $ bale_out DerivErrBootFileFound
let pred = Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_args
skol_info <- mkSkolemInfo (DerivSkol pred)
(tvs', cls_args', deriv_strat') <-
skolemise_when_inferring_context skol_info deriv_ctxt
let deriv_env = DerivEnv
{ denv_overlap_mode :: Maybe OverlapMode
denv_overlap_mode = Maybe OverlapMode
overlap_mode
, denv_tvs :: [TyVar]
denv_tvs = [TyVar]
tvs'
, denv_cls :: Class
denv_cls = Class
cls
, denv_inst_tys :: [Type]
denv_inst_tys = [Type]
cls_args'
, denv_ctxt :: DerivContext
denv_ctxt = DerivContext
deriv_ctxt
, denv_skol_info :: SkolemInfo
denv_skol_info = SkolemInfo
skol_info
, denv_strat :: Maybe (DerivStrategy GhcTc)
denv_strat = Maybe (DerivStrategy GhcTc)
deriv_strat'
, denv_warn :: Maybe (WarningTxt GhcRn)
denv_warn = Maybe (WarningTxt GhcRn)
warn }
runReaderT mk_eqn deriv_env
where
skolemise_when_inferring_context ::
SkolemInfo -> DerivContext
-> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context :: SkolemInfo
-> DerivContext
-> TcM ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context SkolemInfo
skol_info DerivContext
deriv_ctxt =
case DerivContext
deriv_ctxt of
InferContext{} -> do
(skol_subst, tvs') <- SkolemInfo -> [TyVar] -> TcM (Subst, [TyVar])
tcInstSkolTyVars SkolemInfo
skol_info [TyVar]
tvs
let cls_args' = HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
skol_subst [Type]
cls_args
deriv_strat' = (DerivStrategy GhcTc -> DerivStrategy GhcTc)
-> Maybe (DerivStrategy GhcTc) -> Maybe (DerivStrategy GhcTc)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((XViaStrategy GhcTc -> XViaStrategy GhcTc)
-> DerivStrategy GhcTc -> DerivStrategy GhcTc
forall p (pass :: Pass).
(p ~ GhcPass pass) =>
(XViaStrategy p -> XViaStrategy p)
-> DerivStrategy p -> DerivStrategy p
mapDerivStrategy (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
skol_subst))
Maybe (DerivStrategy GhcTc)
deriv_strat
pure (tvs', cls_args', deriv_strat')
SupplyContext{} -> ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
-> TcM ([TyVar], [Type], Maybe (DerivStrategy GhcTc))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVar]
tvs, [Type]
cls_args, Maybe (DerivStrategy GhcTc)
deriv_strat)
bale_out :: DeriveInstanceErrReason -> TcRn ()
bale_out =
TcRnMessage -> TcRn ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcRn ())
-> (DeriveInstanceErrReason -> TcRnMessage)
-> DeriveInstanceErrReason
-> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> TcRnMessage
TcRnCannotDeriveInstance Class
cls [Type]
cls_args Maybe (DerivStrategy GhcTc)
deriv_strat UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
mk_eqn :: DerivM EarlyDerivSpec
mk_eqn :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn = do
DerivEnv { denv_inst_tys = cls_args
, denv_strat = mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
case mb_strat of
Just (StockStrategy XStockStrategy GhcTc
_) -> do
(cls_tys, inst_ty) <- [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
cls_args
dit <- expectAlgTyConApp cls_tys inst_ty
mk_eqn_stock dit
Just (AnyclassStrategy XAnyClassStrategy GhcTc
_) -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_anyclass
Just (ViaStrategy XViaStrategy GhcTc
via_ty) -> do
(cls_tys, inst_ty) <- [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
cls_args
mk_eqn_via cls_tys inst_ty via_ty
Just (NewtypeStrategy XNewtypeStrategy GhcTc
_) -> do
(cls_tys, inst_ty) <- [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
cls_args
dit <- expectAlgTyConApp cls_tys inst_ty
unless (isNewTyCon (dit_rep_tc dit)) $
derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData
mkNewTypeEqn True dit
Maybe (DerivStrategy GhcTc)
Nothing -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs [Type]
inst_tys =
DerivM ([Type], Type)
-> (([Type], Type) -> DerivM ([Type], Type))
-> Maybe ([Type], Type)
-> DerivM ([Type], Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM ([Type], Type)
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrNullaryClasses) ([Type], Type) -> DerivM ([Type], Type)
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([Type], Type) -> DerivM ([Type], Type))
-> Maybe ([Type], Type) -> DerivM ([Type], Type)
forall a b. (a -> b) -> a -> b
$
[Type] -> Maybe ([Type], Type)
forall a. [a] -> Maybe ([a], a)
snocView [Type]
inst_tys
expectAlgTyConApp :: [Type]
-> Type
-> DerivM DerivInstTys
expectAlgTyConApp :: [Type] -> Type -> DerivM DerivInstTys
expectAlgTyConApp [Type]
cls_tys Type
inst_ty = do
fam_envs <- TcRn FamInstEnvs -> ReaderT DerivEnv TcRn FamInstEnvs
forall (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TcRn FamInstEnvs
tcGetFamInstEnvs
case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of
Maybe DerivInstTys
Nothing -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM DerivInstTys
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
DerivErrLastArgMustBeApp
Just DerivInstTys
dit -> do DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
DerivInstTys -> DerivM DerivInstTys
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivInstTys
dit
expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
expectNonDataFamTyCon :: DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon (DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) =
Bool -> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isDataFamilyTyCon TyCon
rep_tc) (ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ())
-> ReaderT DerivEnv TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving (DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ())
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> DeriveInstanceErrReason
DerivErrNoFamilyInstance TyCon
tc [Type]
tc_args
mk_deriv_inst_tys_maybe :: FamInstEnvs
-> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe :: FamInstEnvs -> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe FamInstEnvs
fam_envs [Type]
cls_tys Type
inst_ty =
((TyCon, [Type]) -> DerivInstTys)
-> Maybe (TyCon, [Type]) -> Maybe DerivInstTys
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon, [Type]) -> DerivInstTys
lookup (Maybe (TyCon, [Type]) -> Maybe DerivInstTys)
-> Maybe (TyCon, [Type]) -> Maybe DerivInstTys
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
inst_ty
where
lookup :: (TyCon, [Type]) -> DerivInstTys
lookup :: (TyCon, [Type]) -> DerivInstTys
lookup (TyCon
tc, [Type]
tc_args) =
let (TyCon
rep_tc, [Type]
rep_tc_args, Coercion
_co) = FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [Type]
tc_args
dc_inst_arg_env :: DataConEnv [Type]
dc_inst_arg_env = TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args
in DerivInstTys { dit_cls_tys :: [Type]
dit_cls_tys = [Type]
cls_tys
, dit_tc :: TyCon
dit_tc = TyCon
tc
, dit_tc_args :: [Type]
dit_tc_args = [Type]
tc_args
, dit_rep_tc :: TyCon
dit_rep_tc = TyCon
rep_tc
, dit_rep_tc_args :: [Type]
dit_rep_tc_args = [Type]
rep_tc_args
, dit_dc_inst_arg_env :: DataConEnv [Type]
dit_dc_inst_arg_env = DataConEnv [Type]
dc_inst_arg_env }
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 = overlap_mode
, denv_tvs = tvs
, denv_cls = cls
, denv_inst_tys = inst_tys
, denv_ctxt = deriv_ctxt
, denv_skol_info = skol_info
, denv_warn = warn } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
user_ctxt <- askDerivUserTypeCtxt
doDerivInstErrorChecks1 mechanism
loc <- lift getSrcSpanM
dfun_name <- lift $ newDFunName cls inst_tys loc
case deriv_ctxt of
InferContext Maybe SrcSpan
wildcard ->
do { (inferred_constraints, tvs', inst_tys', mechanism')
<- DerivSpecMechanism
-> DerivM (ThetaSpec, [TyVar], [Type], DerivSpecMechanism)
inferConstraints DerivSpecMechanism
mechanism
; return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs'
, ds_cls = cls, ds_tys = inst_tys'
, ds_theta = inferred_constraints
, ds_skol_info = skol_info
, ds_user_ctxt = user_ctxt
, ds_overlap = overlap_mode
, ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism'
, ds_warn = warn } }
SupplyContext [Type]
theta ->
EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a. a -> ReaderT DerivEnv TcRn a
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> EarlyDerivSpec -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpec [Type] -> EarlyDerivSpec
GivenTheta (DerivSpec [Type] -> EarlyDerivSpec)
-> DerivSpec [Type] -> EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DS
{ ds_loc :: SrcSpan
ds_loc = SrcSpan
loc
, ds_name :: Name
ds_name = Name
dfun_name, ds_tvs :: [TyVar]
ds_tvs = [TyVar]
tvs
, ds_cls :: Class
ds_cls = Class
cls, ds_tys :: [Type]
ds_tys = [Type]
inst_tys
, ds_theta :: [Type]
ds_theta = [Type]
theta
, ds_skol_info :: SkolemInfo
ds_skol_info = SkolemInfo
skol_info
, ds_user_ctxt :: UserTypeCtxt
ds_user_ctxt = UserTypeCtxt
user_ctxt
, ds_overlap :: Maybe OverlapMode
ds_overlap = Maybe OverlapMode
overlap_mode
, ds_standalone_wildcard :: Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
forall a. Maybe a
Nothing
, ds_mechanism :: DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
, ds_warn :: Maybe (WarningTxt GhcRn)
ds_warn = Maybe (WarningTxt GhcRn)
warn }
mk_eqn_stock :: DerivInstTys
-> DerivM EarlyDerivSpec
mk_eqn_stock :: DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_stock DerivInstTys
dit
= do dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let isDeriveAnyClassEnabled =
Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
checkOriginativeSideConditions dit >>= \case
CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns }
StockClassError DeriveInstanceErrReason
why -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
why
OriginativeDerivStatus
CanDeriveAnyClass -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
(DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled)
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 dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let isDeriveAnyClassEnabled =
Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
case xopt LangExt.DeriveAnyClass 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 { 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 :: [Type] -> Type -> Type -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_via [Type]
cls_tys Type
inst_ty Type
via_ty =
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$ DerivSpecVia { dsm_via_cls_tys :: [Type]
dsm_via_cls_tys = [Type]
cls_tys
, dsm_via_inst_ty :: Type
dsm_via_inst_ty = Type
inst_ty
, dsm_via_ty :: Type
dsm_via_ty = Type
via_ty }
mk_eqn_no_strategy :: DerivM EarlyDerivSpec
mk_eqn_no_strategy :: ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_no_strategy = do
DerivEnv { denv_cls = cls
, denv_inst_tys = cls_args } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
fam_envs <- lift tcGetFamInstEnvs
if | Just (cls_tys, inst_ty) <- snocView cls_args
, Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty
-> if | isNewTyCon (dit_rep_tc dit)
-> mkNewTypeEqn False dit
| otherwise
-> do
whenIsJust (hasStockDeriving cls) $ \StockGenFns
_ ->
DerivInstTys -> ReaderT DerivEnv TcRn ()
expectNonDataFamTyCon DerivInstTys
dit
mk_eqn_originative cls dit
| otherwise
-> mk_eqn_anyclass
where
mk_eqn_originative :: Class -> DerivInstTys -> DerivM EarlyDerivSpec
mk_eqn_originative :: Class -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_originative Class
cls dit :: DerivInstTys
dit@(DerivInstTys { dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc }) = do
dflags <- ReaderT DerivEnv TcRn DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let isDeriveAnyClassEnabled
| Class -> Bool
canSafelyDeriveAnyClass Class
cls
= Bool -> DeriveAnyClassEnabled
deriveAnyClassEnabled (Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags)
| Bool
otherwise
= DeriveAnyClassEnabled
YesDeriveAnyClassEnabled
let dac_error
| TyCon -> Bool
isClassTyCon TyCon
rep_tc
= TyCon -> DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrOnlyAnyClassDeriveable TyCon
tc DeriveAnyClassEnabled
isDeriveAnyClassEnabled
| Bool
otherwise
= DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
isDeriveAnyClassEnabled
checkOriginativeSideConditions dit >>= \case
OriginativeDerivStatus
NonDerivableClass -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
dac_error
StockClassError DeriveInstanceErrReason
why -> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving DeriveInstanceErrReason
why
CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns }
OriginativeDerivStatus
CanDeriveAnyClass -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
canSafelyDeriveAnyClass :: Class -> Bool
canSafelyDeriveAnyClass Class
cls =
Maybe (BooleanFormula Name) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (BooleanFormula Name) -> Bool)
-> Maybe (BooleanFormula Name) -> Bool
forall a b. (a -> b) -> a -> b
$ (Name -> Bool)
-> BooleanFormula Name -> Maybe (BooleanFormula Name)
forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied (Bool -> Name -> Bool
forall a b. a -> b -> a
const Bool
False) (Class -> BooleanFormula Name
classMinimalDef Class
cls)
mkNewTypeEqn :: Bool
-> DerivInstTys -> DerivM EarlyDerivSpec
mkNewTypeEqn :: Bool -> DerivInstTys -> ReaderT DerivEnv TcRn EarlyDerivSpec
mkNewTypeEqn Bool
newtype_strat dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tycon
, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args })
= do DerivEnv{denv_cls = cls} <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
dflags <- getDynFlags
let newtype_deriving = Extension -> DynFlags -> Bool
xopt Extension
LangExt.GeneralizedNewtypeDeriving DynFlags
dflags
deriveAnyClass = Extension -> DynFlags -> Bool
xopt Extension
LangExt.DeriveAnyClass DynFlags
dflags
bale_out = UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith (Bool -> UsingGeneralizedNewtypeDeriving
usingGeneralizedNewtypeDeriving Bool
newtype_deriving)
nt_eta_arity = TyCon -> Int
newTyConEtadArity TyCon
rep_tycon
rep_inst_ty = TyCon -> [Type] -> Type
newTyConInstRhs TyCon
rep_tycon [Type]
rep_tc_args
might_be_newtype_derivable
= Bool -> Bool
not (Class -> Bool
non_coercible_class Class
cls)
Bool -> Bool -> Bool
&& Bool
eta_ok
eta_ok = [Type]
rep_tc_args [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
nt_eta_arity
massert (cls_tys `lengthIs` (classArity cls - 1))
if newtype_strat
then
if eta_ok && newtype_deriving
then mk_eqn_newtype dit rep_inst_ty
else bale_out (DerivErrCannotEtaReduceEnough eta_ok)
else
if might_be_newtype_derivable
&& ((newtype_deriving && not deriveAnyClass)
|| std_class_via_coercible cls)
then mk_eqn_newtype dit rep_inst_ty
else checkOriginativeSideConditions dit >>= \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 (m :: * -> *) a. Monad m => m a -> ReaderT DerivEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TcRn () -> ReaderT DerivEnv TcRn ())
-> TcRn () -> ReaderT DerivEnv TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addDiagnosticTc
(TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Class -> TcRnMessage
TcRnDerivingDefaults Class
cls
DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism DerivSpecMechanism
DerivSpecAnyClass
CanDeriveStock StockGenFns
gen_fns -> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
mk_eqn_from_mechanism (DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec)
-> DerivSpecMechanism -> ReaderT DerivEnv TcRn EarlyDerivSpec
forall a b. (a -> b) -> a -> b
$
DerivSpecStock { dsm_stock_dit :: DerivInstTys
dsm_stock_dit = DerivInstTys
dit
, dsm_stock_gen_fns :: StockGenFns
dsm_stock_gen_fns = StockGenFns
gen_fns }
genInstBinds :: DerivSpec ThetaType
-> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds :: DerivSpec [Type]
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds spec :: DerivSpec [Type]
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
, ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
inst_tys, ds_theta :: forall theta. DerivSpec theta -> theta
ds_theta = [Type]
theta, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas
, ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_standalone_wildcard :: forall theta. DerivSpec theta -> Maybe SrcSpan
ds_standalone_wildcard = Maybe SrcSpan
wildcard })
= DerivSpec [Type]
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt DerivSpec [Type]
spec (IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name]))
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv) (InstInfo GhcPs, Bag AuxBindSpec, [Name])
forall a b. (a -> b) -> a -> b
$
do (meth_binds, meth_sigs, aux_specs, unusedNames) <- TcM (LHsBindsLR GhcPs GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_inst_binds
inst_spec <- newDerivClsInst spec
doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
traceTc "newder" (ppr inst_spec)
let inst_info =
InstInfo
{ iSpec :: ClsInst
iSpec = ClsInst
inst_spec
, iBinds :: InstBindings GhcPs
iBinds = InstBindings
{ ib_binds :: LHsBindsLR GhcPs GhcPs
ib_binds = LHsBindsLR GhcPs GhcPs
[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 } }
return (inst_info, aux_specs, 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.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)
([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
-> ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], Bag AuxBindSpec
forall a. Bag a
emptyBag, [])
DerivSpecVia{dsm_via_ty :: DerivSpecMechanism -> Type
dsm_via_ty = Type
via_ty}
-> Type
-> IOEnv
(Env TcGblEnv TcLclEnv)
([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)
([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
gen_newtype_or_via Type
ty = do
let binds :: LHsBindsLR GhcPs GhcPs
binds = SrcSpan
-> Class -> [TyVar] -> [Type] -> Type -> LHsBindsLR GhcPs GhcPs
gen_Newtype_binds SrcSpan
loc Class
clas [TyVar]
tyvars [Type]
inst_tys Type
ty
([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
-> IOEnv
(Env TcGblEnv TcLclEnv)
([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
[GenLocated SrcSpanAnnA (Sig GhcPs)], Bag AuxBindSpec, [Name])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBindsLR GhcPs GhcPs
[GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds, [], Bag AuxBindSpec
forall a. Bag a
emptyBag, [])
genFamInsts :: DerivSpec theta -> TcM [FamInst]
genFamInsts :: forall theta.
DerivSpec theta -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
genFamInsts spec :: DerivSpec theta
spec@(DS { ds_tvs :: forall theta. DerivSpec theta -> [TyVar]
ds_tvs = [TyVar]
tyvars, ds_mechanism :: forall theta. DerivSpec theta -> DerivSpecMechanism
ds_mechanism = DerivSpecMechanism
mechanism
, ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
inst_tys, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc })
= DerivSpec theta
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt DerivSpec theta
spec (IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst])
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall a b. (a -> b) -> a -> b
$
case DerivSpecMechanism
mechanism of
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] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
inst_tys)
mini_subst :: Subst
mini_subst = InScopeSet -> VarEnv Type -> Subst
mkTvSubst ([TyVar] -> InScopeSet
mkInScopeSetList [TyVar]
tyvars) VarEnv Type
mini_env
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
tyfam_insts <-
assertPpr (xopt LangExt.DeriveAnyClass dflags)
(text "genFamInsts: bad derived class" <+> ppr clas) $
mapM (tcATDefault loc mini_subst emptyNameSet)
(classATItems clas)
pure $ concat 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]
-> [Type]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
gen_Newtype_fam_insts SrcSpan
loc Class
clas [TyVar]
tyvars [Type]
inst_tys Type
ty
set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt :: forall theta a. DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt (DS{ ds_loc :: forall theta. DerivSpec theta -> SrcSpan
ds_loc = SrcSpan
loc, ds_cls :: forall theta. DerivSpec theta -> Class
ds_cls = Class
clas, ds_tys :: forall theta. DerivSpec theta -> [Type]
ds_tys = [Type]
tys }) =
SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn a -> TcRn a) -> (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Class -> [Type] -> SDoc
instDeclCtxt3 Class
clas [Type]
tys)
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{}
-> ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
DerivSpecAnyClass{}
-> () -> ReaderT DerivEnv TcRn ()
forall a. a -> ReaderT DerivEnv TcRn a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
DerivSpecVia{}
-> ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks
where
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
standalone <- DerivM Bool
isStandaloneDeriv
when standalone $ do
let bale_out DeriveInstanceErrReason
msg = do err <- DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
msg
lift $ failWithTc err
rdr_env <- lift getGlobalRdrEnv
let 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 -> 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
dc = Maybe (GlobalRdrEltX GREInfo) -> Bool
forall a. Maybe a -> Bool
isNothing (GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
rdr_env Name
dc)
lift $ addUsedDataCons rdr_env rep_tc
unless (not hidden_data_cons) $
bale_out $ DerivErrDataConsNotAllInScope tc
atf_coerce_based_error_checks :: DerivM ()
atf_coerce_based_error_checks :: ReaderT DerivEnv TcRn ()
atf_coerce_based_error_checks = do
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
msg = do err <- DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
msg
lift $ failWithTc err
cls_tyvars = Class -> [TyVar]
classTyVars Class
cls
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
(adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
no_adfs = [TyCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCon]
adf_tcs
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
= (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
kind
= TyVar
last_cls_tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
exactTyCoVarsOfType Type
kind
at_tcs = Class -> [TyCon]
classATs Class
cls
last_cls_tv = Bool -> ([TyVar] -> TyVar) -> [TyVar] -> TyVar
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [TyVar]
cls_tyvars )
[TyVar] -> TyVar
forall a. HasCallStack => [a] -> a
last [TyVar]
cls_tyvars
unless ats_look_sensible $
bale_out (DerivErrHasAssociatedDatatypes
(hasAssociatedDataFamInsts (not no_adfs))
(associatedTyLastVarInKind at_last_cls_tv_in_kinds)
(associatedTyNotParamOverLastTyVar at_without_last_cls_tv)
)
doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 :: Class
-> ClsInst
-> [Type]
-> Maybe SrcSpan
-> DerivSpecMechanism
-> TcRn ()
doDerivInstErrorChecks2 Class
clas ClsInst
clas_inst [Type]
theta Maybe SrcSpan
wildcard DerivSpecMechanism
mechanism
= do { String -> SDoc -> TcRn ()
traceTc String
"doDerivInstErrorChecks2" (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
clas_inst)
; dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
; case wildcard of
Maybe SrcSpan
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just SrcSpan
span -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
span (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let suggParSigs :: SuggestPartialTypeSignatures
suggParSigs = Bool -> SuggestPartialTypeSignatures
suggestPartialTypeSignatures Bool
xpartial_sigs
let dia :: TcRnMessage
dia = SuggestPartialTypeSignatures -> [Type] -> TcRnMessage
TcRnPartialTypeSignatures SuggestPartialTypeSignatures
suggParSigs [Type]
theta
Bool -> TcRnMessage -> TcRn ()
checkTc Bool
xpartial_sigs TcRnMessage
dia
Bool -> TcRnMessage -> TcRn ()
diagnosticTc Bool
wpartial_sigs TcRnMessage
dia
; when (exotic_mechanism && className clas `elem` genericClassNames) $
do { failIfTc (safeLanguageOn dflags)
(TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $
DerivErrSafeHaskellGenericInst)
; when (safeInferOn dflags) (recordUnsafeInfer 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 :: forall a.
UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM a
derivingThingFailWith UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
msg = do
err <- UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrM UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
msg
lift $ failWithTc err
derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> DerivM TcRnMessage
derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrM UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
why
= do DerivEnv { denv_cls = cls
, denv_inst_tys = cls_args
, denv_strat = mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why
derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism DerivSpecMechanism
mechanism DeriveInstanceErrReason
why
= do DerivEnv { denv_cls = cls
, denv_inst_tys = cls_args
, denv_strat = mb_strat } <- ReaderT DerivEnv TcRn DerivEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why
where
newtype_deriving :: UsingGeneralizedNewtypeDeriving
newtype_deriving :: UsingGeneralizedNewtypeDeriving
newtype_deriving
= if DerivSpecMechanism -> Bool
isDerivSpecNewtype DerivSpecMechanism
mechanism then UsingGeneralizedNewtypeDeriving
YesGeneralizedNewtypeDeriving
else UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt LHsSigWcType GhcRn
ty = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the stand-alone deriving instance for")
Int
2 (SDoc -> SDoc
quotes (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
ty))