{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.TyCl.Instance
( tcInstDecls1
, tcInstDeclsDeriv
, tcInstDecls2
)
where
import GHC.Prelude
import GHC.Hs
import GHC.Rename.Bind ( rejectBootDecls )
import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Bind
import GHC.Tc.TyCl
import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )
import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault,
HsSigFun, mkHsSigFun, findMethodBind,
instantiateMethod )
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Gen.Sig
import GHC.Tc.Utils.Monad
import GHC.Tc.Validity
import GHC.Tc.Zonk.Type
import GHC.Tc.Zonk.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated )
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Tc.Deriv
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.Unify
import GHC.Builtin.Names ( unsatisfiableIdName )
import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams )
import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID )
import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
import GHC.Core.Type
import GHC.Core.SimpleOpt
import GHC.Core.Predicate( classMethodInstTy )
import GHC.Tc.Types.Evidence
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.Class
import GHC.Types.Error
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Utils.Logger
import GHC.Data.FastString
import GHC.Types.Id
import GHC.Types.SourceFile
import GHC.Types.SourceText
import GHC.Data.List.SetOps
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.BooleanFormula ( isUnsatisfied )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Tuple
import GHC.Data.Maybe
import Data.List( mapAccumL )
tcInstDecls1
:: [LInstDecl GhcRn]
-> TcM (TcGblEnv,
[InstInfo GhcRn],
[DerivInfo],
ThBindEnv)
tcInstDecls1 :: [LInstDecl (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)], [DerivInfo], ThBindEnv)
tcInstDecls1 [LInstDecl (GhcPass 'Renamed)]
inst_decls
= do {
; stuff <- (GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo]))
-> [GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))]
-> TcRn [([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM LInstDecl (GhcPass 'Renamed)
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcLocalInstDecl [LInstDecl (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (InstDecl (GhcPass 'Renamed))]
inst_decls
; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
fam_insts = [[FamInst]] -> [FamInst]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FamInst]]
fam_insts_s
local_infos = [[InstInfo (GhcPass 'Renamed)]] -> [InstInfo (GhcPass 'Renamed)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InstInfo (GhcPass 'Renamed)]]
local_infos_s
; (gbl_env, th_bndrs) <-
addClsInsts local_infos $
addFamInsts fam_insts
; return ( gbl_env
, local_infos
, concat datafam_deriv_infos
, th_bndrs ) }
tcInstDeclsDeriv
:: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
tcInstDeclsDeriv :: [DerivInfo]
-> [LDerivDecl (GhcPass 'Renamed)]
-> TcM
(TcGblEnv, [InstInfo (GhcPass 'Renamed)],
HsValBinds (GhcPass 'Renamed))
tcInstDeclsDeriv [DerivInfo]
deriv_infos [LDerivDecl (GhcPass 'Renamed)]
derivds
= do th_stage <- TcM ThStage
getStage
if isBrackStage th_stage
then do { gbl_env <- getGblEnv
; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
; return (tcg_env, bagToList info_bag, valbinds) }
addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
addClsInsts :: forall a. [InstInfo (GhcPass 'Renamed)] -> TcM a -> TcM a
addClsInsts [InstInfo (GhcPass 'Renamed)]
infos TcM a
thing_inside
= [ClsInst] -> TcM a -> TcM a
forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv ((InstInfo (GhcPass 'Renamed) -> ClsInst)
-> [InstInfo (GhcPass 'Renamed)] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstInfo (GhcPass 'Renamed) -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec [InstInfo (GhcPass 'Renamed)]
infos) TcM a
thing_inside
addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv)
addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv)
addFamInsts [FamInst]
fam_insts
= [FamInst] -> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv [FamInst]
fam_insts (TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv))
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a b. (a -> b) -> a -> b
$
[TyThing] -> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing]
axioms (TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv))
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"addFamInsts" ([FamInst] -> SDoc
pprFamInsts [FamInst]
fam_insts)
; (gbl_env, th_bndrs) <- [TyCon] -> TcM (TcGblEnv, ThBindEnv)
addTyConsToGblEnv [TyCon]
data_rep_tycons
; return (gbl_env, th_bndrs)
}
where
axioms :: [TyThing]
axioms = (FamInst -> TyThing) -> [FamInst] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map (CoAxiom Branched -> TyThing
ACoAxiom (CoAxiom Branched -> TyThing)
-> (FamInst -> CoAxiom Branched) -> FamInst -> TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoAxiom Unbranched -> CoAxiom Branched
forall (br :: BranchFlag). CoAxiom br -> CoAxiom Branched
toBranchedAxiom (CoAxiom Unbranched -> CoAxiom Branched)
-> (FamInst -> CoAxiom Unbranched) -> FamInst -> CoAxiom Branched
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> CoAxiom Unbranched
famInstAxiom) [FamInst]
fam_insts
data_rep_tycons :: [TyCon]
data_rep_tycons = [FamInst] -> [TyCon]
famInstsRepTyCons [FamInst]
fam_insts
tcLocalInstDecl :: LInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcLocalInstDecl :: LInstDecl (GhcPass 'Renamed)
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcLocalInstDecl (L SrcSpanAnnA
loc (TyFamInstD { tfid_inst :: forall pass. InstDecl pass -> TyFamInstDecl pass
tfid_inst = TyFamInstDecl (GhcPass 'Renamed)
decl }))
= do { fam_inst <- AssocInstInfo -> LTyFamInstDecl (GhcPass 'Renamed) -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
NotAssociated (SrcSpanAnnA
-> TyFamInstDecl (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc TyFamInstDecl (GhcPass 'Renamed)
decl)
; return ([], [fam_inst], []) }
tcLocalInstDecl (L SrcSpanAnnA
loc (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl (GhcPass 'Renamed)
decl }))
= do { (fam_inst, m_deriv_info) <- AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl (GhcPass 'Renamed)
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
NotAssociated TyVarEnv Name
forall a. VarEnv a
emptyVarEnv (SrcSpanAnnA
-> DataFamInstDecl (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc DataFamInstDecl (GhcPass 'Renamed)
decl)
; return ([], [fam_inst], maybeToList m_deriv_info) }
tcLocalInstDecl (L SrcSpanAnnA
loc (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl (GhcPass 'Renamed)
decl }))
= do { (insts, fam_insts, deriv_infos) <- LClsInstDecl (GhcPass 'Renamed)
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcClsInstDecl (SrcSpanAnnA
-> ClsInstDecl (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (ClsInstDecl (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc ClsInstDecl (GhcPass 'Renamed)
decl)
; return (insts, fam_insts, deriv_infos) }
tcClsInstDecl :: LClsInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
tcClsInstDecl :: LClsInstDecl (GhcPass 'Renamed)
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
tcClsInstDecl (L SrcSpanAnnA
loc (ClsInstDecl { cid_ext :: forall pass. ClsInstDecl pass -> XCClsInstDecl pass
cid_ext = XCClsInstDecl (GhcPass 'Renamed)
lwarn
, cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType (GhcPass 'Renamed)
hs_ty, cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds (GhcPass 'Renamed)
binds
, cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [LSig (GhcPass 'Renamed)]
uprags, cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamInstDecl (GhcPass 'Renamed)]
ats
, cid_overlap_mode :: forall pass. ClsInstDecl pass -> Maybe (XRec pass OverlapMode)
cid_overlap_mode = Maybe (XRec (GhcPass 'Renamed) OverlapMode)
overlap_mode
, cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl (GhcPass 'Renamed)]
adts }))
= SrcSpanAnnA
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo]))
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
forall a b. (a -> b) -> a -> b
$
SDoc
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsSigType (GhcPass 'Renamed) -> SDoc
instDeclCtxt1 LHsSigType (GhcPass 'Renamed)
hs_ty) (TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo]))
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
-> TcRn ([InstInfo (GhcPass 'Renamed)], [FamInst], [DerivInfo])
forall a b. (a -> b) -> a -> b
$
do { dfun_ty <- UserTypeCtxt -> LHsSigType (GhcPass 'Renamed) -> TcM PredType
tcHsClsInstType (Bool -> UserTypeCtxt
InstDeclCtxt Bool
False) LHsSigType (GhcPass 'Renamed)
hs_ty
; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
; skol_info <- mkSkolemInfo (mkClsInstSkol clas inst_tys)
; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars
; let tv_skol_prs = [ (Id -> Name
tyVarName Id
tv, Id
skol_tv)
| (Id
tv, Id
skol_tv) <- [Id]
tyvars [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
skol_tvs ]
tv_skol_env = [(Id, Name)] -> TyVarEnv Name
forall a. [(Id, a)] -> VarEnv a
mkVarEnv ([(Id, Name)] -> TyVarEnv Name) -> [(Id, Name)] -> TyVarEnv Name
forall a b. (a -> b) -> a -> b
$ ((Name, Id) -> (Id, Name)) -> [(Name, Id)] -> [(Id, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Id) -> (Id, Name)
forall a b. (a, b) -> (b, a)
swap [(Name, Id)]
tv_skol_prs
n_inferred = (ForAllTyBinder -> Bool) -> [ForAllTyBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
countWhile ((ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
Inferred) (ForAllTyFlag -> Bool)
-> (ForAllTyBinder -> ForAllTyFlag) -> ForAllTyBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForAllTyBinder -> ForAllTyFlag
forall tv argf. VarBndr tv argf -> argf
binderFlag) ([ForAllTyBinder] -> Int) -> [ForAllTyBinder] -> Int
forall a b. (a -> b) -> a -> b
$
([ForAllTyBinder], PredType) -> [ForAllTyBinder]
forall a b. (a, b) -> a
fst (([ForAllTyBinder], PredType) -> [ForAllTyBinder])
-> ([ForAllTyBinder], PredType) -> [ForAllTyBinder]
forall a b. (a -> b) -> a -> b
$ PredType -> ([ForAllTyBinder], PredType)
splitForAllForAllTyBinders PredType
dfun_ty
visible_skol_tvs = Int -> [Id] -> [Id]
forall a. Int -> [a] -> [a]
drop Int
n_inferred [Id]
skol_tvs
; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs)
; (datafam_stuff, tyfam_insts)
<- tcExtendNameTyVarEnv tv_skol_prs $
do { let mini_env = [(Id, PredType)] -> VarEnv PredType
forall a. [(Id, a)] -> VarEnv a
mkVarEnv (Class -> [Id]
classTyVars Class
clas [Id] -> [PredType] -> [(Id, PredType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` HasDebugCallStack => Subst -> [PredType] -> [PredType]
Subst -> [PredType] -> [PredType]
substTys Subst
subst [PredType]
inst_tys)
mini_subst = InScopeSet -> VarEnv PredType -> Subst
mkTvSubst (VarSet -> InScopeSet
mkInScopeSet ([Id] -> VarSet
mkVarSet [Id]
skol_tvs)) VarEnv PredType
mini_env
mb_info = InClsInst { ai_class :: Class
ai_class = Class
clas
, ai_tyvars :: [Id]
ai_tyvars = [Id]
visible_skol_tvs
, ai_inst_env :: VarEnv PredType
ai_inst_env = VarEnv PredType
mini_env }
; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts
; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats
; is_boot <- tcIsHsBootOrSig
; let atItems = Class -> [ClassATItem]
classATItems Class
clas
; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats)
(if is_boot then [] else atItems)
; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty)
; let warn = (GenLocated SrcSpanAnnP (WarningTxt (GhcPass 'Renamed))
-> WarningTxt (GhcPass 'Renamed))
-> Maybe (GenLocated SrcSpanAnnP (WarningTxt (GhcPass 'Renamed)))
-> Maybe (WarningTxt (GhcPass 'Renamed))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP (WarningTxt (GhcPass 'Renamed))
-> WarningTxt (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated SrcSpanAnnP (WarningTxt (GhcPass 'Renamed)))
XCClsInstDecl (GhcPass 'Renamed)
lwarn
; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
tyvars theta clas inst_tys warn
; let inst_binds = InstBindings
{ ib_binds :: LHsBinds (GhcPass 'Renamed)
ib_binds = LHsBinds (GhcPass 'Renamed)
binds
, ib_tyvars :: [Name]
ib_tyvars = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
Var.varName [Id]
tyvars
, ib_pragmas :: [LSig (GhcPass 'Renamed)]
ib_pragmas = [LSig (GhcPass 'Renamed)]
uprags
, ib_extensions :: [Extension]
ib_extensions = []
, ib_derived :: Bool
ib_derived = Bool
False }
inst_info = InstInfo { iSpec :: ClsInst
iSpec = ClsInst
ispec, iBinds :: InstBindings (GhcPass 'Renamed)
iBinds = InstBindings (GhcPass 'Renamed)
inst_binds }
(datafam_insts, m_deriv_infos) = unzip datafam_stuff
deriv_infos = [Maybe DerivInfo] -> [DerivInfo]
forall a. [Maybe a] -> [a]
catMaybes [Maybe DerivInfo]
m_deriv_infos
all_insts = [FamInst]
tyfam_insts [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
datafam_insts
; gbl_env <- getGblEnv;
; case tcg_src gbl_env of
{ HscSource
HsSrcFile -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; HsBootOrSig HsBootOrSig
boot_or_sig ->
do { HsBootOrSig
-> (NonEmpty (GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed)))
-> BadBootDecls)
-> [GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))]
-> TcRn ()
forall decl.
HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> TcRn ()
rejectBootDecls HsBootOrSig
boot_or_sig NonEmpty (LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> BadBootDecls
NonEmpty (GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed)))
-> BadBootDecls
BootBindsRn LHsBinds (GhcPass 'Renamed)
[GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))]
binds
; HsBootOrSig
-> (NonEmpty (GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)))
-> BadBootDecls)
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> TcRn ()
forall decl.
HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> TcRn ()
rejectBootDecls HsBootOrSig
boot_or_sig NonEmpty (LSig (GhcPass 'Renamed)) -> BadBootDecls
NonEmpty (GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)))
-> BadBootDecls
BootInstanceSigs [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
uprags } }
; return ([inst_info], all_insts, deriv_infos) }
where
defined_ats :: NameSet
defined_ats = [Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed)) -> Name)
-> [GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed))]
-> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyFamInstDecl (GhcPass 'Renamed) -> IdP (GhcPass 'Renamed)
TyFamInstDecl (GhcPass 'Renamed) -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (TyFamInstDecl (GhcPass 'Renamed) -> Name)
-> (GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed))
-> TyFamInstDecl (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed))
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed))
-> TyFamInstDecl (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc) [LTyFamInstDecl (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (TyFamInstDecl (GhcPass 'Renamed))]
ats)
NameSet -> NameSet -> NameSet
`unionNameSet`
[Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> Name)
-> [GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))]
-> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnN Name -> Name)
-> (GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnN Name)
-> GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
-> LIdP (GhcPass 'Renamed)
FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnN Name
forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon
(FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnN Name)
-> (GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnN Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataFamInstDecl (GhcPass 'Renamed)
-> FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn
(DataFamInstDecl (GhcPass 'Renamed)
-> FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed)))
-> (GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> DataFamInstDecl (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))
-> DataFamInstDecl (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (DataFamInstDecl (GhcPass 'Renamed))]
adts)
tcTyFamInstDecl :: AssocInstInfo
-> LTyFamInstDecl GhcRn -> TcM FamInst
tcTyFamInstDecl :: AssocInstInfo -> LTyFamInstDecl (GhcPass 'Renamed) -> TcM FamInst
tcTyFamInstDecl AssocInstInfo
mb_clsinfo (L SrcSpanAnnA
loc decl :: TyFamInstDecl (GhcPass 'Renamed)
decl@(TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = TyFamInstEqn (GhcPass 'Renamed)
eqn }))
= SrcSpanAnnA -> TcM FamInst -> TcM FamInst
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM FamInst -> TcM FamInst) -> TcM FamInst -> TcM FamInst
forall a b. (a -> b) -> a -> b
$
TyFamInstDecl (GhcPass 'Renamed) -> TcM FamInst -> TcM FamInst
forall a. TyFamInstDecl (GhcPass 'Renamed) -> TcM a -> TcM a
tcAddTyFamInstCtxt TyFamInstDecl (GhcPass 'Renamed)
decl (TcM FamInst -> TcM FamInst) -> TcM FamInst -> TcM FamInst
forall a b. (a -> b) -> a -> b
$
do { let fam_lname :: LIdP (GhcPass 'Renamed)
fam_lname = FamEqn
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> LIdP (GhcPass 'Renamed)
forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon TyFamInstEqn (GhcPass 'Renamed)
FamEqn
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
eqn
; fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
fam_lname
; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc
; checkTc (isTypeFamilyTyCon fam_tc) $
TcRnIllegalInstance $ IllegalFamilyInstance $
FamilyCategoryMismatch fam_tc
; checkTc (isOpenTypeFamilyTyCon fam_tc) $
TcRnIllegalInstance $ IllegalFamilyInstance $
NotAnOpenFamilyTyCon fam_tc
; (co_ax_branch, co_ax_validity_info)
<- tcTyFamInstEqn fam_tc mb_clsinfo
(L (l2l $ getLoc fam_lname) eqn)
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
; checkTyFamEqnValidityInfo fam_tc co_ax_validity_info
; checkValidCoAxBranch fam_tc co_ax_branch
; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
; let axiom = Name -> TyCon -> KnotTied CoAxBranch -> CoAxiom Unbranched
mkUnbranchedCoAxiom Name
rep_tc_name TyCon
fam_tc KnotTied CoAxBranch
co_ax_branch
; newFamInst SynFamilyInst axiom }
tcFamInstDeclChecks :: AssocInstInfo -> TypeOrData -> TyCon -> TcM ()
tcFamInstDeclChecks :: AssocInstInfo -> TypeOrData -> TyCon -> TcRn ()
tcFamInstDeclChecks AssocInstInfo
mb_clsinfo TypeOrData
ty_or_data TyCon
fam_tc
= do {
; String -> SDoc -> TcRn ()
traceTc String
"tcFamInstDecl" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
; type_families <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilies
; hs_src <- tcHscSource
; checkTc type_families (TcRnTyFamsDisabled (TyFamsDisabledInstance fam_tc))
; case hs_src of
HsBootOrSig HsBootOrSig
boot_or_sig ->
TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsBootOrSig -> BadBootDecls -> TcRnMessage
TcRnIllegalHsBootOrSigDecl HsBootOrSig
boot_or_sig (TyCon -> BadBootDecls
BootFamInst TyCon
fam_tc)
HscSource
HsSrcFile ->
() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; checkTc (isFamilyTyCon fam_tc) $
TcRnIllegalInstance $ IllegalFamilyInstance $
NotAFamilyTyCon ty_or_data fam_tc
; when (isNotAssociated mb_clsinfo &&
isTyConAssoc fam_tc) $
addErr $ TcRnIllegalInstance $ IllegalFamilyInstance
$ InvalidAssoc $ InvalidAssocInstance
$ AssocInstanceNotInAClass fam_tc
}
tcDataFamInstDecl ::
AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl :: AssocInstInfo
-> TyVarEnv Name
-> LDataFamInstDecl (GhcPass 'Renamed)
-> TcM (FamInst, Maybe DerivInfo)
tcDataFamInstDecl AssocInstInfo
mb_clsinfo TyVarEnv Name
tv_skol_env
(L SrcSpanAnnA
loc decl :: DataFamInstDecl (GhcPass 'Renamed)
decl@(DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
FamEqn { feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsFamEqnPats pass
feqn_pats = HsFamEqnPats (GhcPass 'Renamed)
hs_pats
, feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = lfam_name :: LIdP (GhcPass 'Renamed)
lfam_name@(L SrcSpanAnnN
_ Name
fam_name)
, feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity = LexicalFixity
fixity
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn { dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType = Maybe (XRec (GhcPass 'Renamed) CType)
cType
, dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt
, dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl (GhcPass 'Renamed))
hs_cons
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind (GhcPass 'Renamed))
m_ksig
, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving (GhcPass 'Renamed)
derivs } }}))
= SrcSpanAnnA
-> TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo))
-> TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall a b. (a -> b) -> a -> b
$
DataFamInstDecl (GhcPass 'Renamed)
-> TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall a. DataFamInstDecl (GhcPass 'Renamed) -> TcM a -> TcM a
tcAddDataFamInstCtxt DataFamInstDecl (GhcPass 'Renamed)
decl (TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo))
-> TcM (FamInst, Maybe DerivInfo) -> TcM (FamInst, Maybe DerivInfo)
forall a b. (a -> b) -> a -> b
$
do { fam_tc <- GenLocated SrcSpanAnnN Name -> TcM TyCon
tcLookupLocatedTyCon LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
lfam_name
; tcFamInstDeclChecks mb_clsinfo IAmData fam_tc
; checkTc (isDataFamilyTyCon fam_tc) $
TcRnIllegalInstance $ IllegalFamilyInstance $
FamilyCategoryMismatch fam_tc
; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons
; skol_info <- mkSkolemInfo FamInstSkol
; let new_or_data = DataDefnCons (GenLocated SrcSpanAnnA (ConDecl (GhcPass 'Renamed)))
-> NewOrData
forall a. DataDefnCons a -> NewOrData
dataDefnConsNewOrData DataDefnCons (LConDecl (GhcPass 'Renamed))
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl (GhcPass 'Renamed)))
hs_cons
; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta)
<- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity
hs_ctxt hs_pats m_ksig new_or_data
; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats
eta_tvs = (TyConBinder -> Id) -> [TyConBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [TyConBinder]
eta_tcbs
post_eta_qtvs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
eta_tvs) [Id]
qtvs
full_tcbs = [Id] -> VarSet -> [TyConBinder]
mkTyConBindersPreferAnon [Id]
post_eta_qtvs
(PredType -> VarSet
tyCoVarsOfType ([Id] -> PredType -> PredType
mkSpecForAllTys [Id]
eta_tvs PredType
tc_res_kind))
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
eta_tcbs
; let flav = NewOrData -> TyConFlavour (ZonkAny 0)
forall tc. NewOrData -> TyConFlavour tc
newOrDataToFlavour NewOrData
new_or_data
; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind
; let extra_pats = (TyConBinder -> PredType) -> [TyConBinder] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> PredType
mkTyVarTy (Id -> PredType) -> (TyConBinder -> Id) -> TyConBinder -> PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar) [TyConBinder]
extra_tcbs
all_pats = [PredType]
pats [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
`chkAppend` [PredType]
extra_pats
orig_res_ty = TyCon -> [PredType] -> PredType
mkTyConApp TyCon
fam_tc [PredType]
all_pats
tc_ty_binders = [TyConBinder]
full_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_tcbs
; traceTc "tcDataFamInstDecl 1" $
vcat [ text "Fam tycon:" <+> ppr fam_tc
, text "Pats:" <+> ppr pats
, text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)
, text "all_pats:" <+> ppr all_pats
, text "tc_ty_binders" <+> ppr tc_ty_binders
, text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
, text "tc_res_kind:" <+> ppr tc_res_kind
, text "eta_pats" <+> ppr eta_pats
, text "eta_tcbs" <+> ppr eta_tcbs ]
; (ty_binders, res_kind, all_pats, eta_pats, stupid_theta,
zonked_post_eta_qtvs, zonked_eta_tvs) <-
initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_ty_binders) $ \ [TyConBinder]
ty_binders ->
do { res_kind <- PredType -> ZonkTcM PredType
zonkTcTypeToTypeX PredType
tc_res_kind
; all_pats <- zonkTcTypesToTypesX all_pats
; eta_pats <- zonkTcTypesToTypesX eta_pats
; stupid_theta <- zonkTcTypesToTypesX stupid_theta
; zonked_post_eta_qtvs <- mapM lookupTyVarX post_eta_qtvs
; zonked_eta_tvs <- mapM lookupTyVarX eta_tvs
; return (ty_binders, res_kind, all_pats, eta_pats, stupid_theta,
zonked_post_eta_qtvs, zonked_eta_tvs) }
; traceTc "tcDataFamInstDecl" $
vcat [ text "Fam tycon:" <+> ppr fam_tc
, text "Pats:" <+> ppr pats
, text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)
, text "all_pats:" <+> ppr all_pats
, text "ty_binders" <+> ppr ty_binders
, text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
, text "res_kind:" <+> ppr res_kind
, text "eta_pats" <+> ppr eta_pats
, text "eta_tcbs" <+> ppr eta_tcbs ]
; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(TyCon
rec_rep_tc, (CoAxiom Unbranched, PredType)
_) ->
do { data_cons <- [Id] -> TcM (DataDefnCons DataCon) -> TcM (DataDefnCons DataCon)
forall r. [Id] -> TcM r -> TcM r
tcExtendTyVarEnv ([TyConBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_ty_binders) (TcM (DataDefnCons DataCon) -> TcM (DataDefnCons DataCon))
-> TcM (DataDefnCons DataCon) -> TcM (DataDefnCons DataCon)
forall a b. (a -> b) -> a -> b
$
DataDeclInfo
-> TyCon
-> [TyConBinder]
-> PredType
-> DataDefnCons (LConDecl (GhcPass 'Renamed))
-> TcM (DataDefnCons DataCon)
tcConDecls (PredType -> DataDeclInfo
DDataInstance PredType
orig_res_ty) TyCon
rec_rep_tc [TyConBinder]
tc_ty_binders PredType
tc_res_kind
DataDefnCons (LConDecl (GhcPass 'Renamed))
hs_cons
; rep_tc_name <- newFamInstTyConName lfam_name pats
; axiom_name <- newFamInstAxiomName lfam_name [pats]
; tc_rhs <- case data_cons of
DataTypeCons Bool
type_data [DataCon]
data_cons -> AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs)
-> AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a b. (a -> b) -> a -> b
$
Bool -> Bool -> [DataCon] -> AlgTyConRhs
mkLevPolyDataTyConRhs
(HasDebugCallStack => PredType -> Bool
PredType -> Bool
isFixedRuntimeRepKind PredType
res_kind)
Bool
type_data
[DataCon]
data_cons
NewTypeCon DataCon
data_con -> Name
-> TyCon -> DataCon -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
rep_tc_name TyCon
rec_rep_tc DataCon
data_con
; let ax_rhs = TyCon -> [PredType] -> PredType
mkTyConApp TyCon
rep_tc ([Id] -> [PredType]
mkTyVarTys [Id]
zonked_post_eta_qtvs)
axiom = Role
-> Name
-> [Id]
-> [Id]
-> [Id]
-> TyCon
-> [PredType]
-> PredType
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Representational Name
axiom_name
[Id]
zonked_post_eta_qtvs [Id]
zonked_eta_tvs
[] TyCon
fam_tc [PredType]
eta_pats PredType
ax_rhs
parent = CoAxiom Unbranched -> TyCon -> [PredType] -> AlgTyConFlav
DataFamInstTyCon CoAxiom Unbranched
axiom TyCon
fam_tc [PredType]
all_pats
rep_tc = Name
-> [TyConBinder]
-> PredType
-> [Role]
-> Maybe CType
-> [PredType]
-> AlgTyConRhs
-> AlgTyConFlav
-> Bool
-> TyCon
mkAlgTyCon Name
rep_tc_name
[TyConBinder]
ty_binders PredType
res_kind
((TyConBinder -> Role) -> [TyConBinder] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map (Role -> TyConBinder -> Role
forall a b. a -> b -> a
const Role
Nominal) [TyConBinder]
ty_binders)
((GenLocated SrcSpanAnnP CType -> CType)
-> Maybe (GenLocated SrcSpanAnnP CType) -> Maybe CType
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP CType -> CType
forall l e. GenLocated l e -> e
unLoc Maybe (XRec (GhcPass 'Renamed) CType)
Maybe (GenLocated SrcSpanAnnP CType)
cType) [PredType]
stupid_theta
AlgTyConRhs
tc_rhs AlgTyConFlav
parent
Bool
gadt_syntax
; return (rep_tc, (axiom, ax_rhs)) }
; let ax_branch = CoAxiom Unbranched -> KnotTied CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
axiom
; checkConsistentFamInst mb_clsinfo fam_tc ax_branch
; checkFamPatBinders fam_tc zonked_post_eta_qtvs non_user_tvs eta_pats ax_rhs
; checkValidCoAxBranch fam_tc ax_branch
; checkValidTyCon rep_tc
; let scoped_tvs = (Id -> (Name, Id)) -> [Id] -> [(Name, Id)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> (Name, Id)
mk_deriv_info_scoped_tv_pr (TyCon -> [Id]
tyConTyVars TyCon
rep_tc)
m_deriv_info = case HsDeriving (GhcPass 'Renamed)
derivs of
[] -> Maybe DerivInfo
forall a. Maybe a
Nothing
HsDeriving (GhcPass 'Renamed)
preds ->
DerivInfo -> Maybe DerivInfo
forall a. a -> Maybe a
Just (DerivInfo -> Maybe DerivInfo) -> DerivInfo -> Maybe DerivInfo
forall a b. (a -> b) -> a -> b
$ DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
rep_tc
, di_scoped_tvs :: [(Name, Id)]
di_scoped_tvs = [(Name, Id)]
scoped_tvs
, di_clauses :: HsDeriving (GhcPass 'Renamed)
di_clauses = HsDeriving (GhcPass 'Renamed)
preds
, di_ctxt :: SDoc
di_ctxt = DataFamInstDecl (GhcPass 'Renamed) -> SDoc
tcMkDataFamInstCtxt DataFamInstDecl (GhcPass 'Renamed)
decl }
; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
; return (fam_inst, m_deriv_info) }
where
eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
eta_reduce :: TyCon -> [PredType] -> ([PredType], [TyConBinder])
eta_reduce TyCon
fam_tc [PredType]
pats
= [(PredType, VarSet, TyConBndrVis)]
-> [TyConBinder] -> ([PredType], [TyConBinder])
forall {c}.
[(PredType, VarSet, c)]
-> [VarBndr Id c] -> ([PredType], [VarBndr Id c])
go ([(PredType, VarSet, TyConBndrVis)]
-> [(PredType, VarSet, TyConBndrVis)]
forall a. [a] -> [a]
reverse ([PredType]
-> [VarSet] -> [TyConBndrVis] -> [(PredType, VarSet, TyConBndrVis)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [PredType]
pats [VarSet]
fvs_s [TyConBndrVis]
vis_s)) []
where
vis_s :: [TyConBndrVis]
vis_s :: [TyConBndrVis]
vis_s = TyCon -> [PredType] -> [TyConBndrVis]
tcbVisibilities TyCon
fam_tc [PredType]
pats
fvs_s :: [TyCoVarSet]
(VarSet
_, [VarSet]
fvs_s) = (VarSet -> PredType -> (VarSet, VarSet))
-> VarSet -> [PredType] -> (VarSet, [VarSet])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL VarSet -> PredType -> (VarSet, VarSet)
add_fvs VarSet
emptyVarSet [PredType]
pats
add_fvs :: VarSet -> PredType -> (VarSet, VarSet)
add_fvs VarSet
fvs PredType
pat = (VarSet
fvs VarSet -> VarSet -> VarSet
`unionVarSet` PredType -> VarSet
tyCoVarsOfType PredType
pat, VarSet
fvs)
go :: [(PredType, VarSet, c)]
-> [VarBndr Id c] -> ([PredType], [VarBndr Id c])
go ((PredType
pat, VarSet
fvs_to_the_left, c
tcb_vis):[(PredType, VarSet, c)]
pats) [VarBndr Id c]
etad_tvs
| Just Id
tv <- PredType -> Maybe Id
getTyVar_maybe PredType
pat
, Bool -> Bool
not (Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
fvs_to_the_left)
= [(PredType, VarSet, c)]
-> [VarBndr Id c] -> ([PredType], [VarBndr Id c])
go [(PredType, VarSet, c)]
pats (Id -> c -> VarBndr Id c
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
tv c
tcb_vis VarBndr Id c -> [VarBndr Id c] -> [VarBndr Id c]
forall a. a -> [a] -> [a]
: [VarBndr Id c]
etad_tvs)
go [(PredType, VarSet, c)]
pats [VarBndr Id c]
etad_tvs = ([PredType] -> [PredType]
forall a. [a] -> [a]
reverse (((PredType, VarSet, c) -> PredType)
-> [(PredType, VarSet, c)] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (PredType, VarSet, c) -> PredType
forall a b c. (a, b, c) -> a
fstOf3 [(PredType, VarSet, c)]
pats), [VarBndr Id c]
etad_tvs)
mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar)
mk_deriv_info_scoped_tv_pr :: Id -> (Name, Id)
mk_deriv_info_scoped_tv_pr Id
tv =
let n :: Name
n = TyVarEnv Name -> Name -> Id -> Name
forall a. VarEnv a -> a -> Id -> a
lookupWithDefaultVarEnv TyVarEnv Name
tv_skol_env (Id -> Name
tyVarName Id
tv) Id
tv
in (Name
n, Id
tv)
tcDataFamInstHeader
:: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn
-> LexicalFixity -> Maybe (LHsContext GhcRn)
-> HsFamEqnPats GhcRn -> Maybe (LHsKind GhcRn)
-> NewOrData
-> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType)
AssocInstInfo
mb_clsinfo SkolemInfo
skol_info TyCon
fam_tc HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
hs_outer_bndrs LexicalFixity
fixity
Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt HsFamEqnPats (GhcPass 'Renamed)
hs_pats Maybe (LHsKind (GhcPass 'Renamed))
m_ksig NewOrData
new_or_data
= do { String -> SDoc -> TcRn ()
traceTc String
"tcDataFamInstHeader {" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsArg
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsFamEqnPats (GhcPass 'Renamed)
[HsArg
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))]
hs_pats)
; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))
<- String
-> TcM
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcDataFamInstHeader" (TcM
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType))))
-> TcM
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType)))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
-> TcM ([PredType], PredType, PredType, PredType)
-> TcM
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType))
forall a.
SkolemInfo
-> HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs SkolemInfo
skol_info HsOuterFamEqnTyVarBndrs (GhcPass 'Renamed)
hs_outer_bndrs (TcM ([PredType], PredType, PredType, PredType)
-> TcM
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType)))
-> TcM ([PredType], PredType, PredType, PredType)
-> TcM
(HsOuterFamEqnTyVarBndrs GhcTc,
([PredType], PredType, PredType, PredType))
forall a b. (a -> b) -> a -> b
$
do { stupid_theta <- Maybe (LHsContext (GhcPass 'Renamed)) -> TcM [PredType]
tcHsContext Maybe (LHsContext (GhcPass 'Renamed))
hs_ctxt
; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
; (lhs_applied_ty, lhs_applied_kind)
<- tcInstInvisibleTyBinders lhs_ty lhs_kind
; addConsistencyConstraints mb_clsinfo lhs_ty
; res_kind <- tc_kind_sig m_ksig
; let hs_lhs = PromotionFlag
-> LexicalFixity
-> IdP (GhcPass 'Renamed)
-> HsFamEqnPats (GhcPass 'Renamed)
-> LHsKind (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag
-> LexicalFixity
-> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)]
-> LHsType (GhcPass p)
nlHsTyConApp PromotionFlag
NotPromoted LexicalFixity
fixity (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
fam_tc) HsFamEqnPats (GhcPass 'Renamed)
hs_pats
; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind
; traceTc "tcDataFamInstHeader" $
vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig]
; return ( stupid_theta
, lhs_applied_ty
, lhs_applied_kind
, res_kind ) }
; outer_bndrs <- scopedSortOuter outer_bndrs
; let outer_tvs = HsOuterFamEqnTyVarBndrs GhcTc -> [Id]
forall flag. HsOuterTyVarBndrs flag GhcTc -> [Id]
outerTyVars HsOuterFamEqnTyVarBndrs GhcTc
outer_bndrs
; checkFamTelescope tclvl hs_outer_bndrs outer_tvs
; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty
; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
; let final_tvs = [Id] -> [Id]
scopedSort ([Id]
qtvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
outer_tvs)
; reportUnsolvedEqualities skol_info final_tvs tclvl wanted
; (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) <-
liftZonkM $ do
{ final_tvs <- mapM zonkTcTyVarToTcTyVar final_tvs
; non_user_tvs <- mapM zonkTcTyVarToTcTyVar qtvs
; lhs_ty <- zonkTcType lhs_ty
; master_res_kind <- zonkTcType master_res_kind
; instance_res_kind <- zonkTcType instance_res_kind
; stupid_theta <- zonkTcTypes stupid_theta
; return (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) }
; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind
; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind
; let pats = PredType -> [PredType]
unravelFamInstPats PredType
lhs_ty
; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) }
where
fam_name :: Name
fam_name = TyCon -> Name
tyConName TyCon
fam_tc
data_ctxt :: UserTypeCtxt
data_ctxt = Name -> UserTypeCtxt
DataKindCtxt Name
fam_name
tc_kind_sig :: Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> TcM PredType
tc_kind_sig Maybe (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
Nothing
= do { unlifted_newtypes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes
; case new_or_data of
NewOrData
NewType | Bool
unlifted_newtypes -> TcM PredType
newOpenTypeKind
NewOrData
DataType | Bool
unlifted_datatypes -> TcM PredType
newOpenTypeKind
NewOrData
_ -> PredType -> TcM PredType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PredType
liftedTypeKind
}
tc_kind_sig (Just GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_kind)
= do { sig_kind <- UserTypeCtxt -> LHsKind (GhcPass 'Renamed) -> TcM PredType
tcLHsKindSig UserTypeCtxt
data_ctxt LHsKind (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
hs_kind
; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind
; return inner_kind' }
tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
-> TcM (LHsBinds GhcTc)
tcInstDecls2 :: [LTyClDecl (GhcPass 'Renamed)]
-> [InstInfo (GhcPass 'Renamed)] -> TcM (LHsBinds GhcTc)
tcInstDecls2 [LTyClDecl (GhcPass 'Renamed)]
tycl_decls [InstInfo (GhcPass 'Renamed)]
inst_decls
= do {
let class_decls :: [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
class_decls = (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)) -> Bool)
-> [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
-> [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyClDecl (GhcPass 'Renamed) -> Bool
forall pass. TyClDecl pass -> Bool
isClassDecl (TyClDecl (GhcPass 'Renamed) -> Bool)
-> (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))
-> TyClDecl (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))
-> TyClDecl (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc) [LTyClDecl (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
tycl_decls
; dm_binds_s <- (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LTyClDecl (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
tcClassDecl2 [GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed))]
class_decls
; let dm_binds = [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]]
dm_binds_s
; let dm_ids = CollectFlag GhcTc -> LHsBinds GhcTc -> [IdP GhcTc]
forall p idR.
CollectPass p =>
CollectFlag p -> LHsBindsLR p idR -> [IdP p]
collectHsBindsBinders CollectFlag GhcTc
forall p. CollectFlag p
CollNoDictBinders LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
dm_binds
; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
mapM tcInstDecl2 inst_decls
; return (dm_binds ++ concat inst_binds_s) }
tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
tcInstDecl2 :: InstInfo (GhcPass 'Renamed) -> TcM (LHsBinds GhcTc)
tcInstDecl2 (InstInfo { iSpec :: forall a. InstInfo a -> ClsInst
iSpec = ClsInst
ispec, iBinds :: forall a. InstInfo a -> InstBindings a
iBinds = InstBindings (GhcPass 'Renamed)
ibinds })
= TcM (LHsBinds GhcTc)
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall r. TcRn r -> TcRn r -> TcRn r
recoverM ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$
SrcSpan -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (PredType -> SDoc
instDeclCtxt2 PredType
dfun_ty) (TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc))
-> TcM (LHsBinds GhcTc) -> TcM (LHsBinds GhcTc)
forall a b. (a -> b) -> a -> b
$
do {
(skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- PredType
-> TcM (SkolemInfoAnon, [Id], [PredType], Class, [PredType])
tcSkolDFunType PredType
dfun_ty
; dfun_ev_vars <- newEvVars dfun_theta
; let (class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = HasDebugCallStack => Subst -> [PredType] -> [PredType]
Subst -> [PredType] -> [PredType]
substTheta ([Id] -> [PredType] -> Subst
HasDebugCallStack => [Id] -> [PredType] -> Subst
zipTvSubst [Id]
class_tyvars [PredType]
inst_tys) [PredType]
sc_theta
; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
; dfun_ev_binds_var <- newTcEvBinds
; let dfun_ev_binds = EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
dfun_ev_binds_var
; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
<- pushTcLevelM $
do { (sc_ids, sc_binds, sc_implics)
<- tcSuperClasses skol_info dfun_id clas inst_tyvars
dfun_ev_vars dfun_ev_binds sc_theta'
; (meth_ids, meth_binds, meth_implics)
<- tcMethods skol_info dfun_id clas inst_tyvars dfun_ev_vars
inst_tys dfun_ev_binds spec_inst_info
op_items ibinds
; return ( sc_ids ++ meth_ids
, sc_binds ++ meth_binds
, sc_implics `unionBags` meth_implics ) }
; imp <- newImplication
; emitImplication $
imp { ic_tclvl = tclvl
, ic_skols = inst_tyvars
, ic_given = dfun_ev_vars
, ic_wanted = mkImplicWC sc_meth_implics
, ic_binds = dfun_ev_binds_var
, ic_info = skol_info }
; self_dict <- newDict clas inst_tys
; let class_tc = Class -> TyCon
classTyCon Class
clas
loc' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
dict_constr = TyCon -> DataCon
tyConSingleDataCon TyCon
class_tc
dict_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
mkVarBind IdP GhcTc
Id
self_dict (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' HsExpr GhcTc
con_app_args)
con_app_tys = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap ([PredType] -> HsWrapper
mkWpTyApps [PredType]
inst_tys) (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
ConLike -> HsExpr GhcTc
mkConLikeTc (DataCon -> ConLike
RealDataCon DataCon
dict_constr)
con_app_args = (HsExpr GhcTc -> Id -> HsExpr GhcTc)
-> HsExpr GhcTc -> [Id] -> HsExpr GhcTc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HsExpr GhcTc -> Id -> HsExpr GhcTc
app_to_meth HsExpr GhcTc
con_app_tys [Id]
sc_meth_ids
app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
app_to_meth HsExpr GhcTc
fun Id
meth_id = XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
NoExtField
noExtField (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' HsExpr GhcTc
fun)
(SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (HsWrapper -> Id -> HsExpr GhcTc
wrapId HsWrapper
arg_wrapper Id
meth_id))
inst_tv_tys = [Id] -> [PredType]
mkTyVarTys [Id]
inst_tyvars
arg_wrapper = [Id] -> HsWrapper
mkWpEvVarApps [Id]
dfun_ev_vars HsWrapper -> HsWrapper -> HsWrapper
<.> [PredType] -> HsWrapper
mkWpTyApps [PredType]
inst_tv_tys
is_newtype = TyCon -> Bool
isNewTyCon TyCon
class_tc
dfun_id_w_prags = Id -> [Id] -> Id
addDFunPrags Id
dfun_id [Id]
sc_meth_ids
dfun_spec_prags
| Bool
is_newtype = [LTcSpecPrag] -> TcSpecPrags
SpecPrags []
| Bool
otherwise = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_inst_prags
export = ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: Id
abe_poly = Id
dfun_id_w_prags
, abe_mono :: Id
abe_mono = Id
self_dict
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
dfun_spec_prags }
main_bind = XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
AbsBinds { abs_tvs :: [Id]
abs_tvs = [Id]
inst_tyvars
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
dfun_ev_vars
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
, abs_binds :: LHsBinds GhcTc
abs_binds = [LHsBind GhcTc
dict_bind]
, abs_sig :: Bool
abs_sig = Bool
True }
; return (L loc' main_bind : sc_meth_binds)
}
where
dfun_id :: Id
dfun_id = ClsInst -> Id
instanceDFunId ClsInst
ispec
dfun_ty :: PredType
dfun_ty = Id -> PredType
idType Id
dfun_id
loc :: SrcSpan
loc = Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
dfun_id
addDFunPrags :: DFunId -> [Id] -> DFunId
addDFunPrags :: Id -> [Id] -> Id
addDFunPrags Id
dfun_id [Id]
sc_meth_ids
| Bool
is_newtype
= Id
dfun_id Id -> Unfolding -> Id
`setIdUnfolding` SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
defaultSimpleOpts UnfoldingSource
StableSystemSrc Int
0 CoreExpr
con_app
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
alwaysInlinePragma { inl_sat = Just 0 }
| Bool
otherwise
= Id
dfun_id Id -> Unfolding -> Id
`setIdUnfolding` [Id] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding [Id]
dfun_bndrs DataCon
dict_con [CoreExpr]
dict_args
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
dfunInlinePragma
where
con_app :: CoreExpr
con_app = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
dfun_bndrs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
dict_con)) [CoreExpr]
dict_args
dict_args :: [CoreExpr]
dict_args = (PredType -> CoreExpr) -> [PredType] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map PredType -> CoreExpr
forall b. PredType -> Expr b
Type [PredType]
inst_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++
[CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id) [Id]
dfun_bndrs | Id
id <- [Id]
sc_meth_ids]
([Id]
dfun_tvs, [PredType]
dfun_theta, Class
clas, [PredType]
inst_tys) = PredType -> ([Id], [PredType], Class, [PredType])
tcSplitDFunTy (Id -> PredType
idType Id
dfun_id)
ev_ids :: [Id]
ev_ids = Int -> [PredType] -> [Id]
mkTemplateLocalsNum Int
1 [PredType]
dfun_theta
dfun_bndrs :: [Id]
dfun_bndrs = [Id]
dfun_tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
ev_ids
clas_tc :: TyCon
clas_tc = Class -> TyCon
classTyCon Class
clas
dict_con :: DataCon
dict_con = TyCon -> DataCon
tyConSingleDataCon TyCon
clas_tc
is_newtype :: Bool
is_newtype = TyCon -> Bool
isNewTyCon TyCon
clas_tc
wrapId :: HsWrapper -> Id -> HsExpr GhcTc
wrapId :: HsWrapper -> Id -> HsExpr GhcTc
wrapId HsWrapper
wrapper Id
id = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrapper (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (Id -> GenLocated SrcSpanAnnN Id
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Id
id))
tcSuperClasses :: SkolemInfoAnon -> DFunId -> Class -> [TcTyVar]
-> [EvVar]
-> TcEvBinds
-> TcThetaType
-> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
tcSuperClasses :: SkolemInfoAnon
-> Id
-> Class
-> [Id]
-> [Id]
-> TcEvBinds
-> [PredType]
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcSuperClasses SkolemInfoAnon
skol_info Id
dfun_id Class
cls [Id]
tyvars [Id]
dfun_evs TcEvBinds
dfun_ev_binds [PredType]
sc_theta
= do { (ids, binds, implics) <- ((PredType, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication))
-> [(PredType, Int)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Implication])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M (PredType, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
tc_super ([PredType] -> [Int] -> [(PredType, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PredType]
sc_theta [Int
fIRST_TAG..])
; return (ids, binds, listToBag implics) }
where
loc :: SrcSpan
loc = Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
dfun_id
tc_super :: (PredType, Int)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), Implication)
tc_super (PredType
sc_pred, Int
n)
= do { (sc_implic, ev_binds_var, sc_ev_tm)
<- SkolemInfoAnon
-> TcM EvTerm -> TcM (Implication, EvBindsVar, EvTerm)
forall result.
SkolemInfoAnon
-> TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints SkolemInfoAnon
skol_info (TcM EvTerm -> TcM (Implication, EvBindsVar, EvTerm))
-> TcM EvTerm -> TcM (Implication, EvBindsVar, EvTerm)
forall a b. (a -> b) -> a -> b
$
CtOrigin -> PredType -> TcM EvTerm
emitWanted (ClsInstOrQC -> NakedScFlag -> CtOrigin
ScOrigin ClsInstOrQC
IsClsInst NakedScFlag
NakedSc) PredType
sc_pred
; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
; sc_ev_id <- newEvVar sc_pred
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id EvCanonical sc_ev_tm
; let sc_top_ty = [Id] -> [PredType] -> PredType -> PredType
tcMkDFunSigmaTy [Id]
tyvars ((Id -> PredType) -> [Id] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
idType [Id]
dfun_evs) PredType
sc_pred
sc_top_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
Name -> PredType -> PredType -> Id
mkLocalId Name
sc_top_name PredType
ManyTy PredType
sc_top_ty
export = ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_poly :: Id
abe_poly = Id
sc_top_id
, abe_mono :: Id
abe_mono = Id
sc_ev_id
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
noSpecPrags }
local_ev_binds = EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
ev_binds_var
bind = XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
AbsBinds { abs_tvs :: [Id]
abs_tvs = [Id]
tyvars
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
dfun_evs
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
dfun_ev_binds, TcEvBinds
local_ev_binds]
, abs_binds :: LHsBinds GhcTc
abs_binds = []
, abs_sig :: Bool
abs_sig = Bool
False }
; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) }
checkInstConstraints :: SkolemInfoAnon -> TcM result
-> TcM (Implication, EvBindsVar, result)
checkInstConstraints :: forall result.
SkolemInfoAnon
-> TcM result -> TcM (Implication, EvBindsVar, result)
checkInstConstraints SkolemInfoAnon
skol_info TcM result
thing_inside
= do { (tclvl, wanted, result) <- TcM result -> TcM (TcLevel, WantedConstraints, result)
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM result -> TcM (TcLevel, WantedConstraints, result))
-> TcM result -> TcM (TcLevel, WantedConstraints, result)
forall a b. (a -> b) -> a -> b
$
TcM result
thing_inside
; ev_binds_var <- newTcEvBinds
; implic <- newImplication
; let implic' = Implication
implic { ic_tclvl = tclvl
, ic_wanted = wanted
, ic_binds = ev_binds_var
, ic_info = skol_info }
; return (implic', ev_binds_var, result) }
tcMethods :: SkolemInfoAnon -> DFunId -> Class
-> [TcTyVar] -> [EvVar]
-> [TcType]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings GhcRn
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcMethods :: SkolemInfoAnon
-> Id
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> ([LTcSpecPrag], TcPragEnv)
-> [ClassOpItem]
-> InstBindings (GhcPass 'Renamed)
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
tcMethods SkolemInfoAnon
skol_info Id
dfun_id Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds ([LTcSpecPrag]
spec_inst_prags, TcPragEnv
prag_fn) [ClassOpItem]
op_items
(InstBindings { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass 'Renamed)
binds
, ib_tyvars :: forall a. InstBindings a -> [Name]
ib_tyvars = [Name]
lexical_tvs
, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig (GhcPass 'Renamed)]
sigs
, ib_extensions :: forall a. InstBindings a -> [Extension]
ib_extensions = [Extension]
exts
, ib_derived :: forall a. InstBindings a -> Bool
ib_derived = Bool
is_derived })
= [(Name, Id)]
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ([Name]
lexical_tvs [Name] -> [Id] -> [(Name, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
tyvars) (TcM ([Id], LHsBinds GhcTc, Bag Implication)
-> TcM ([Id], LHsBinds GhcTc, Bag Implication))
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
-> TcM ([Id], LHsBinds GhcTc, Bag Implication)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcInstMeth" ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds (GhcPass 'Renamed)
[GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))]
binds)
; TcRn ()
checkMinimalDefinition
; TcRn ()
checkMethBindMembership
; (ids, binds, mb_implics) <- [Extension]
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a. [Extension] -> TcM a -> TcM a
set_exts [Extension]
exts (TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication]))
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a b. (a -> b) -> a -> b
$
TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a. TcM a -> TcM a
unset_warnings_deriving (TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication]))
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall a b. (a -> b) -> a -> b
$
(ClassOpItem
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication))
-> [ClassOpItem]
-> TcM
([Id], [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
[Maybe Implication])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
ClassOpItem
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Id, GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc),
Maybe Implication)
tc_item [ClassOpItem]
op_items
; return (ids, binds, listToBag (catMaybes mb_implics)) }
where
set_exts :: [LangExt.Extension] -> TcM a -> TcM a
set_exts :: forall a. [Extension] -> TcM a -> TcM a
set_exts [Extension]
es TcM a
thing = (Extension -> TcM a -> TcM a) -> TcM a -> [Extension] -> TcM a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Extension -> TcM a -> TcM a
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM TcM a
thing [Extension]
es
unset_warnings_deriving :: TcM a -> TcM a
unset_warnings_deriving :: forall a. TcM a -> TcM a
unset_warnings_deriving
| Bool
is_derived = WarningFlag
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnInaccessibleCode
| Bool
otherwise = TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall a. a -> a
id
hs_sig_fn :: HsSigFun
hs_sig_fn = [LSig (GhcPass 'Renamed)] -> HsSigFun
mkHsSigFun [LSig (GhcPass 'Renamed)]
sigs
inst_loc :: SrcSpan
inst_loc = Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
dfun_id
unsat_thetas :: [(Id, PredType)]
unsat_thetas =
(Id -> Maybe (Id, PredType)) -> [Id] -> [(Id, PredType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ Id
id -> (Id
id,) (PredType -> (Id, PredType))
-> Maybe PredType -> Maybe (Id, PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PredType -> Maybe PredType
isUnsatisfiableCt_maybe (Id -> PredType
idType Id
id)) [Id]
dfun_ev_vars
tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_item (Id
sel_id, DefMethInfo
dm_info)
| Just (LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
user_bind, SrcSpan
bndr_loc, [LSig (GhcPass 'Renamed)]
prags) <- Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
(LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed), SrcSpan,
[LSig (GhcPass 'Renamed)])
findMethodBind (Id -> Name
idName Id
sel_id) LHsBinds (GhcPass 'Renamed)
binds TcPragEnv
prag_fn
= SkolemInfoAnon
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig (GhcPass 'Renamed)]
-> Id
-> LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> SrcSpan
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
tcMethodBody SkolemInfoAnon
skol_info Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived HsSigFun
hs_sig_fn
[LTcSpecPrag]
spec_inst_prags [LSig (GhcPass 'Renamed)]
prags
Id
sel_id LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
user_bind SrcSpan
bndr_loc
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"tc_def" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
sel_id)
; Id -> DefMethInfo -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_default Id
sel_id DefMethInfo
dm_info }
tc_default :: Id -> DefMethInfo
-> TcM (TcId, LHsBind GhcTc, Maybe Implication)
tc_default :: Id -> DefMethInfo -> TcM (Id, LHsBind GhcTc, Maybe Implication)
tc_default Id
sel_id DefMethInfo
mb_dm = case DefMethInfo
mb_dm of
DefMethInfo
_ | (Id
theta_id,PredType
unsat_msg) : [(Id, PredType)]
_ <- [(Id, PredType)]
unsat_thetas
-> do { (meth_id, _) <- Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys Id
sel_id
; unsat_id <- tcLookupId unsatisfiableIdName
; let meth_rhs = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc' (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsWrapper -> Id -> HsExpr GhcTc
wrapId
( [EvTerm] -> HsWrapper
mkWpEvApps [CoreExpr -> EvTerm
EvExpr (CoreExpr -> EvTerm) -> CoreExpr -> EvTerm
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
Var Id
theta_id]
HsWrapper -> HsWrapper -> HsWrapper
<.> [PredType] -> HsWrapper
mkWpTyApps [HasDebugCallStack => PredType -> PredType
PredType -> PredType
getRuntimeRep PredType
meth_tau, PredType
unsat_msg, PredType
meth_tau])
Id
unsat_id
meth_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
mkVarBind IdP GhcTc
Id
meth_id (LHsExpr GhcTc -> LHsBind GhcTc) -> LHsExpr GhcTc -> LHsBind GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
lam_wrapper LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
meth_rhs
; return (meth_id, meth_bind, Nothing) }
Just (Name
dm_name, DefMethSpec PredType
dm_spec) ->
do { (meth_bind, inline_prags) <- SrcSpan
-> Id
-> Class
-> Id
-> Name
-> DefMethSpec PredType
-> TcM
(LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed),
[LSig (GhcPass 'Renamed)])
mkDefMethBind SrcSpan
inst_loc Id
dfun_id Class
clas Id
sel_id Name
dm_name DefMethSpec PredType
dm_spec
; tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
dfun_ev_binds is_derived hs_sig_fn
spec_inst_prags inline_prags
sel_id meth_bind inst_loc }
DefMethInfo
Nothing ->
do { String -> SDoc -> TcRn ()
traceTc String
"tc_def: warn" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
sel_id)
; (meth_id, _) <- Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys Id
sel_id
; dflags <- getDynFlags
; let meth_rhs = DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_rhs DynFlags
dflags
meth_bind = IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
mkVarBind IdP GhcTc
Id
meth_id (LHsExpr GhcTc -> LHsBind GhcTc) -> LHsExpr GhcTc -> LHsBind GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
lam_wrapper LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
meth_rhs
; return (meth_id, meth_bind, Nothing) }
where
inst_loc' :: SrcSpanAnnA
inst_loc' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
inst_loc
error_rhs :: DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_rhs DynFlags
dflags = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc'
(HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
NoExtField
noExtField LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_fun (DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_msg DynFlags
dflags)
error_fun :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_fun = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc' (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
HsWrapper -> Id -> HsExpr GhcTc
wrapId ([PredType] -> HsWrapper
mkWpTyApps
[ HasDebugCallStack => PredType -> PredType
PredType -> PredType
getRuntimeRep PredType
meth_tau, PredType
meth_tau])
Id
nO_METHOD_BINDING_ERROR_ID
error_msg :: DynFlags -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
error_msg DynFlags
dflags = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
inst_loc'
(XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
NoExtField
noExtField (XHsStringPrim GhcTc -> ByteString -> HsLit GhcTc
forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim XHsStringPrim GhcTc
SourceText
NoSourceText
(String -> ByteString
unsafeMkByteString (DynFlags -> String
error_string DynFlags
dflags))))
meth_tau :: PredType
meth_tau = Id -> [PredType] -> PredType
classMethodInstTy Id
sel_id [PredType]
inst_tys
error_string :: DynFlags -> String
error_string DynFlags
dflags = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags
([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
inst_loc, SDoc
forall doc. IsLine doc => doc
vbar, SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
sel_id) ])
lam_wrapper :: HsWrapper
lam_wrapper = [Id] -> HsWrapper
mkWpTyLams [Id]
tyvars HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpEvLams [Id]
dfun_ev_vars
checkMinimalDefinition :: TcRn ()
checkMinimalDefinition
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Id, PredType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, PredType)]
unsat_thetas) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Maybe ClassMinimalDef -> (ClassMinimalDef -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust ((Name -> Bool) -> ClassMinimalDef -> Maybe ClassMinimalDef
forall a.
Eq a =>
(a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
isUnsatisfied Name -> Bool
methodExists (Class -> ClassMinimalDef
classMinimalDef Class
clas)) ((ClassMinimalDef -> TcRn ()) -> TcRn ())
-> (ClassMinimalDef -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
ClassMinimalDef -> TcRn ()
warnUnsatisfiedMinimalDefinition
methodExists :: Name -> Bool
methodExists Name
meth = Maybe
(GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed)), SrcSpan,
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))])
-> Bool
forall a. Maybe a -> Bool
isJust (Name
-> LHsBinds (GhcPass 'Renamed)
-> TcPragEnv
-> Maybe
(LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed), SrcSpan,
[LSig (GhcPass 'Renamed)])
findMethodBind Name
meth LHsBinds (GhcPass 'Renamed)
binds TcPragEnv
prag_fn)
checkMethBindMembership :: TcRn ()
checkMethBindMembership
= (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ())
-> (Name -> TcRnMessage) -> Name -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> TcRnMessage
TcRnBadMethodErr (Class -> Name
className Class
clas)) [Name]
mismatched_meths
where
bind_nms :: [Name]
bind_nms = (GenLocated SrcSpanAnnN Name -> Name)
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpanAnnN Name] -> [Name])
-> [GenLocated SrcSpanAnnN Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ LHsBinds (GhcPass 'Renamed) -> [LIdP (GhcPass 'Renamed)]
forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
collectMethodBinders LHsBinds (GhcPass 'Renamed)
binds
cls_meth_nms :: [Name]
cls_meth_nms = (ClassOpItem -> Name) -> [ClassOpItem] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
idName (Id -> Name) -> (ClassOpItem -> Id) -> ClassOpItem -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassOpItem -> Id
forall a b. (a, b) -> a
fst) [ClassOpItem]
op_items
mismatched_meths :: [Name]
mismatched_meths = [Name]
bind_nms [Name] -> [Name] -> [Name]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [Name]
cls_meth_nms
tcMethodBody :: SkolemInfoAnon
-> Class -> [TcTyVar] -> [EvVar] -> [TcType]
-> TcEvBinds -> Bool
-> HsSigFun
-> [LTcSpecPrag] -> [LSig GhcRn]
-> Id -> LHsBind GhcRn -> SrcSpan
-> TcM (TcId, LHsBind GhcTc, Maybe Implication)
tcMethodBody :: SkolemInfoAnon
-> Class
-> [Id]
-> [Id]
-> [PredType]
-> TcEvBinds
-> Bool
-> HsSigFun
-> [LTcSpecPrag]
-> [LSig (GhcPass 'Renamed)]
-> Id
-> LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> SrcSpan
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
tcMethodBody SkolemInfoAnon
skol_info Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys
TcEvBinds
dfun_ev_binds Bool
is_derived
HsSigFun
sig_fn [LTcSpecPrag]
spec_inst_prags [LSig (GhcPass 'Renamed)]
prags
Id
sel_id (L SrcSpanAnnA
bind_loc HsBind (GhcPass 'Renamed)
meth_bind) SrcSpan
bndr_loc
= TcM (Id, LHsBind GhcTc, Maybe Implication)
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
add_meth_ctxt (TcM (Id, LHsBind GhcTc, Maybe Implication)
-> TcM (Id, LHsBind GhcTc, Maybe Implication))
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcMethodBody" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
sel_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> PredType
idType Id
sel_id) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
bndr_loc)
; (global_meth_id, local_meth_id) <- SrcSpan -> TcM (Id, Id) -> TcM (Id, Id)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
bndr_loc (TcM (Id, Id) -> TcM (Id, Id)) -> TcM (Id, Id) -> TcM (Id, Id)
forall a b. (a -> b) -> a -> b
$
Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars
[PredType]
inst_tys Id
sel_id
; let lm_bind = HsBind (GhcPass 'Renamed)
meth_bind { fun_id = L (noAnnSrcSpan bndr_loc)
(idName local_meth_id) }
; (meth_implic, ev_binds_var, tc_bind)
<- checkInstConstraints skol_info $
tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
; global_meth_id <- addInlinePrags global_meth_id prags
; spec_prags <- tcSpecPrags global_meth_id prags
; let specs = Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags Id
global_meth_id [LTcSpecPrag]
spec_inst_prags [LTcSpecPrag]
spec_prags
export = ABE { abe_poly :: Id
abe_poly = Id
global_meth_id
, abe_mono :: Id
abe_mono = Id
local_meth_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
idHsWrapper
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
specs }
local_ev_binds = EvBindsVar -> TcEvBinds
TcEvBinds EvBindsVar
ev_binds_var
full_bind = XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
AbsBinds { abs_tvs :: [Id]
abs_tvs = [Id]
tyvars
, abs_ev_vars :: [Id]
abs_ev_vars = [Id]
dfun_ev_vars
, abs_exports :: [ABExport]
abs_exports = [ABExport
export]
, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
dfun_ev_binds, TcEvBinds
local_ev_binds]
, abs_binds :: LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
tc_bind
, abs_sig :: Bool
abs_sig = Bool
True }
; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
where
add_meth_ctxt :: TcM (Id, LHsBind GhcTc, Maybe Implication)
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
add_meth_ctxt TcM (Id, LHsBind GhcTc, Maybe Implication)
thing
| Bool
is_derived = SDoc
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
-> TcM (Id, LHsBind GhcTc, Maybe Implication)
forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt (Id -> Class -> [PredType] -> SDoc
derivBindCtxt Id
sel_id Class
clas [PredType]
inst_tys) TcM (Id, LHsBind GhcTc, Maybe Implication)
thing
| Bool
otherwise = TcM (Id, LHsBind GhcTc, Maybe Implication)
thing
tcMethodBodyHelp :: HsSigFun -> Id -> TcId
-> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp :: HsSigFun
-> Id
-> Id
-> LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc)
tcMethodBodyHelp HsSigFun
hs_sig_fn Id
sel_id Id
local_meth_id LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
meth_bind
| Just LHsSigType (GhcPass 'Renamed)
hs_sig_ty <- HsSigFun
hs_sig_fn Name
sel_name
= do { (sig_ty, hs_wrap)
<- SrcSpan -> TcRn (PredType, HsWrapper) -> TcRn (PredType, HsWrapper)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_sig_ty) (TcRn (PredType, HsWrapper) -> TcRn (PredType, HsWrapper))
-> TcRn (PredType, HsWrapper) -> TcRn (PredType, HsWrapper)
forall a b. (a -> b) -> a -> b
$
do { inst_sigs <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.InstanceSigs
; checkTc inst_sigs (TcRnMisplacedInstSig sel_name hs_sig_ty)
; let ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name ReportRedundantConstraints
NoRRC
; sig_ty <- tcHsSigType ctxt hs_sig_ty
; let local_meth_ty = Id -> PredType
idType Id
local_meth_id
; let orig = Name -> PredType -> PredType -> CtOrigin
InstanceSigOrigin Name
sel_name PredType
sig_ty PredType
local_meth_ty
; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
tcSubTypeSigma orig ctxt sig_ty local_meth_ty
; return (sig_ty, hs_wrap) }
; inner_meth_name <- newName (nameOccName sel_name)
; let ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name (LHsSigType (GhcPass 'Renamed) -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType (GhcPass 'Renamed)
hs_sig_ty)
inner_meth_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
Name -> PredType -> PredType -> Id
mkLocalId Name
inner_meth_name PredType
ManyTy PredType
sig_ty
inner_meth_sig = CSig { sig_bndr :: Id
sig_bndr = Id
inner_meth_id
, sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
, sig_loc :: SrcSpan
sig_loc = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LHsSigType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))
hs_sig_ty }
; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
; let export = ABE { abe_poly :: Id
abe_poly = Id
local_meth_id
, abe_mono :: Id
abe_mono = Id
inner_id
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
hs_wrap
, abe_prags :: TcSpecPrags
abe_prags = TcSpecPrags
noSpecPrags }
; return (singleton $ L (getLoc meth_bind) $ XHsBindsLR $
AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = [export]
, abs_binds = tc_bind, abs_ev_binds = []
, abs_sig = True }) }
| Bool
otherwise
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
sel_name ReportRedundantConstraints
NoRRC
tc_sig :: TcCompleteSig
tc_sig = UserTypeCtxt -> Id -> TcCompleteSig
completeSigFromId UserTypeCtxt
ctxt Id
local_meth_id
; (tc_bind, _) <- TcPragEnv
-> TcCompleteSig
-> LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM (LHsBinds GhcTc, [Scaled Id])
tcPolyCheck TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
no_prag_fn TcCompleteSig
tc_sig LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
meth_bind
; return tc_bind }
where
sel_name :: Name
sel_name = Id -> Name
idName Id
sel_id
no_prag_fn :: TcPragEnv
no_prag_fn = TcPragEnv
emptyPragEnv
mkMethIds :: Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcId)
mkMethIds :: Class -> [Id] -> [Id] -> [PredType] -> Id -> TcM (Id, Id)
mkMethIds Class
clas [Id]
tyvars [Id]
dfun_ev_vars [PredType]
inst_tys Id
sel_id
= do { poly_meth_name <- OccName -> TcM Name
newName (OccName -> OccName
mkClassOpAuxOcc OccName
sel_occ)
; local_meth_name <- newName sel_occ
; let poly_meth_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
Name -> PredType -> PredType -> Id
mkLocalId Name
poly_meth_name PredType
ManyTy PredType
poly_meth_ty
local_meth_id = HasDebugCallStack => Name -> PredType -> PredType -> Id
Name -> PredType -> PredType -> Id
mkLocalId Name
local_meth_name PredType
ManyTy PredType
local_meth_ty
; return (poly_meth_id, local_meth_id) }
where
sel_name :: Name
sel_name = Id -> Name
idName Id
sel_id
!sel_occ :: OccName
sel_occ = Name -> OccName
nameOccName Name
sel_name
local_meth_ty :: PredType
local_meth_ty = Class -> Id -> [PredType] -> PredType
instantiateMethod Class
clas Id
sel_id [PredType]
inst_tys
poly_meth_ty :: PredType
poly_meth_ty = [Id] -> [PredType] -> PredType -> PredType
HasDebugCallStack => [Id] -> [PredType] -> PredType -> PredType
mkSpecSigmaTy [Id]
tyvars [PredType]
theta PredType
local_meth_ty
theta :: [PredType]
theta = (Id -> PredType) -> [Id] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
idType [Id]
dfun_ev_vars
methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
methSigCtxt :: Name -> PredType -> PredType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
methSigCtxt Name
sel_name PredType
sig_ty PredType
meth_ty TidyEnv
env0
= do { (env1, sig_ty) <- TidyEnv -> PredType -> ZonkM (TidyEnv, PredType)
zonkTidyTcType TidyEnv
env0 PredType
sig_ty
; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
; let msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking that instance signature for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
sel_name))
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is more general than its signature in the class"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Instance sig:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
sig_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" Class sig:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
meth_ty ])
; return (env2, msg) }
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
mk_meth_spec_prags Id
meth_id [LTcSpecPrag]
spec_inst_prags [LTcSpecPrag]
spec_prags_for_me
= [LTcSpecPrag] -> TcSpecPrags
SpecPrags ([LTcSpecPrag]
spec_prags_for_me [LTcSpecPrag] -> [LTcSpecPrag] -> [LTcSpecPrag]
forall a. [a] -> [a] -> [a]
++ [LTcSpecPrag]
spec_prags_from_inst)
where
spec_prags_from_inst :: [LTcSpecPrag]
spec_prags_from_inst
| InlinePragma -> Bool
isInlinePragma (Id -> InlinePragma
idInlinePragma Id
meth_id)
= []
| Bool
otherwise
= [ SrcSpan -> TcSpecPrag -> LTcSpecPrag
forall l e. l -> e -> GenLocated l e
L SrcSpan
inst_loc (Id -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag Id
meth_id HsWrapper
wrap InlinePragma
inl)
| L SrcSpan
inst_loc (SpecPrag Id
_ HsWrapper
wrap InlinePragma
inl) <- [LTcSpecPrag]
spec_inst_prags]
mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name
-> DefMethSpec Type
-> TcM (LHsBind GhcRn, [LSig GhcRn])
mkDefMethBind :: SrcSpan
-> Id
-> Class
-> Id
-> Name
-> DefMethSpec PredType
-> TcM
(LHsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed),
[LSig (GhcPass 'Renamed)])
mkDefMethBind SrcSpan
loc Id
dfun_id Class
clas Id
sel_id Name
dm_name DefMethSpec PredType
dm_spec
= do { logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; dm_id <- tcLookupId dm_name
; let inline_prag = Id -> InlinePragma
idInlinePragma Id
dm_id
inline_prags | InlinePragma -> Bool
isAnyInlinePragma InlinePragma
inline_prag
= [Sig (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XInlineSig (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed)
-> InlinePragma
-> Sig (GhcPass 'Renamed)
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig (EpaLocation, EpToken "#-}", ActivationAnn)
XInlineSig (GhcPass 'Renamed)
forall a. NoAnn a => a
noAnn LIdP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN Name
fn InlinePragma
inline_prag)]
| Bool
otherwise
= []
; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
FormatHaskell
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr bind)]))
; return (bind, inline_prags) }
where
([Id]
_, [PredType]
_, Class
_, [PredType]
inst_tys) = PredType -> ([Id], [PredType], Class, [PredType])
tcSplitDFunTy (Id -> PredType
idType Id
dfun_id)
([Id]
_, PredType
_, PredType
sel_tau) = PredType -> ([Id], PredType, PredType)
tcSplitMethodTy (Id -> PredType
idType Id
sel_id)
([TcInvisTVBinder]
sel_tvbs, PredType
_) = PredType -> ([TcInvisTVBinder], PredType)
tcSplitForAllInvisTVBinders PredType
sel_tau
visible_inst_tys :: [PredType]
visible_inst_tys =
[ PredType
ty | (TyConBinder
tcb, PredType
ty) <- TyCon -> [TyConBinder]
tyConBinders (Class -> TyCon
classTyCon Class
clas) [TyConBinder] -> [PredType] -> [(TyConBinder, PredType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [PredType]
inst_tys
, TyConBinder -> ForAllTyFlag
tyConBinderForAllTyFlag TyConBinder
tcb ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
/= ForAllTyFlag
Inferred ]
visible_sel_tvbs :: [TcInvisTVBinder]
visible_sel_tvbs =
case DefMethSpec PredType
dm_spec of
DefMethSpec PredType
VanillaDM -> (TcInvisTVBinder -> Bool) -> [TcInvisTVBinder] -> [TcInvisTVBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TcInvisTVBinder
tvb -> TcInvisTVBinder -> Specificity
forall tv argf. VarBndr tv argf -> argf
binderFlag TcInvisTVBinder
tvb Specificity -> Specificity -> Bool
forall a. Eq a => a -> a -> Bool
/= Specificity
InferredSpec) [TcInvisTVBinder]
sel_tvbs
GenericDM {} -> []
visible_sel_pats :: [GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
visible_sel_pats = (TcInvisTVBinder
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
-> [TcInvisTVBinder]
-> [GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
forall a b. (a -> b) -> [a] -> [b]
map TcInvisTVBinder -> LPat (GhcPass 'Renamed)
TcInvisTVBinder -> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
mk_ty_pat [TcInvisTVBinder]
visible_sel_tvbs
visible_sel_tys :: [PredType]
visible_sel_tys = (TcInvisTVBinder -> PredType) -> [TcInvisTVBinder] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> PredType
mkTyVarTy (Id -> PredType)
-> (TcInvisTVBinder -> Id) -> TcInvisTVBinder -> PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcInvisTVBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar) [TcInvisTVBinder]
visible_sel_tvbs
fn :: GenLocated SrcSpanAnnN Name
fn = Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Id -> Name
idName Id
sel_id)
rhs :: LocatedA (HsExpr (GhcPass 'Renamed))
rhs = (LocatedA (HsExpr (GhcPass 'Renamed))
-> PredType -> LocatedA (HsExpr (GhcPass 'Renamed)))
-> LocatedA (HsExpr (GhcPass 'Renamed))
-> [PredType]
-> LocatedA (HsExpr (GhcPass 'Renamed))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr (GhcPass 'Renamed)
-> PredType -> LHsExpr (GhcPass 'Renamed)
LocatedA (HsExpr (GhcPass 'Renamed))
-> PredType -> LocatedA (HsExpr (GhcPass 'Renamed))
mk_vta (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Renamed)
Name
dm_name) ([PredType] -> LocatedA (HsExpr (GhcPass 'Renamed)))
-> [PredType] -> LocatedA (HsExpr (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
[PredType]
visible_inst_tys [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType]
visible_sel_tys
bind :: GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))
bind = SrcSpanAnnA
-> HsBind (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc)
(HsBind (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed)))
-> HsBind (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsBind (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ Origin
-> GenLocated SrcSpanAnnN Name
-> [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
-> HsBind (GhcPass 'Renamed)
mkTopFunBind (GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
SkipPmc) GenLocated SrcSpanAnnN Name
fn
[HsMatchContext (LIdP (NoGhcTc (GhcPass 'Renamed)))
-> LocatedE [LPat (GhcPass 'Renamed)]
-> LocatedA (HsExpr (GhcPass 'Renamed))
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN Name
fn AnnFunRhs
forall a. NoAnn a => a
noAnn) ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
-> GenLocated
EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))]
visible_sel_pats) LocatedA (HsExpr (GhcPass 'Renamed))
rhs]
mk_ty_pat :: VarBndr TyVar Specificity -> LPat GhcRn
mk_ty_pat :: TcInvisTVBinder -> LPat (GhcPass 'Renamed)
mk_ty_pat (Bndr Id
tv Specificity
spec) =
Pat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
-> Pat (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
XInvisPat (GhcPass 'Renamed)
-> HsTyPat (NoGhcTc (GhcPass 'Renamed)) -> Pat (GhcPass 'Renamed)
forall p. XInvisPat p -> HsTyPat (NoGhcTc p) -> Pat p
InvisPat XInvisPat (GhcPass 'Renamed)
Specificity
spec (HsTyPat (NoGhcTc (GhcPass 'Renamed)) -> Pat (GhcPass 'Renamed))
-> HsTyPat (NoGhcTc (GhcPass 'Renamed)) -> Pat (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$
XHsTP (NoGhcTc (GhcPass 'Renamed))
-> LHsType (NoGhcTc (GhcPass 'Renamed))
-> HsTyPat (NoGhcTc (GhcPass 'Renamed))
forall pass. XHsTP pass -> LHsType pass -> HsTyPat pass
HsTP ([Name] -> [Name] -> [Name] -> HsTyPatRn
HsTPRn [] [Id -> Name
tyVarName Id
tv] []) (LHsType (NoGhcTc (GhcPass 'Renamed))
-> HsTyPat (NoGhcTc (GhcPass 'Renamed)))
-> LHsType (NoGhcTc (GhcPass 'Renamed))
-> HsTyPat (NoGhcTc (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$
PromotionFlag
-> IdP (GhcPass 'Renamed) -> LHsKind (GhcPass 'Renamed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted (IdP (GhcPass 'Renamed) -> LHsKind (GhcPass 'Renamed))
-> IdP (GhcPass 'Renamed) -> LHsKind (GhcPass 'Renamed)
forall a b. (a -> b) -> a -> b
$
Id -> Name
tyVarName Id
tv
mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
mk_vta :: LHsExpr (GhcPass 'Renamed)
-> PredType -> LHsExpr (GhcPass 'Renamed)
mk_vta LHsExpr (GhcPass 'Renamed)
fun PredType
ty = HsExpr (GhcPass 'Renamed) -> LocatedA (HsExpr (GhcPass 'Renamed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XAppTypeE (GhcPass 'Renamed)
-> LHsExpr (GhcPass 'Renamed)
-> LHsWcType (NoGhcTc (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE (GhcPass 'Renamed)
NoExtField
noExtField LHsExpr (GhcPass 'Renamed)
fun
(LHsKind (GhcPass 'Renamed)
-> HsWildCardBndrs (GhcPass 'Renamed) (LHsKind (GhcPass 'Renamed))
forall thing. thing -> HsWildCardBndrs (GhcPass 'Renamed) thing
mkEmptyWildCardBndrs (LHsKind (GhcPass 'Renamed)
-> HsWildCardBndrs (GhcPass 'Renamed) (LHsKind (GhcPass 'Renamed)))
-> LHsKind (GhcPass 'Renamed)
-> HsWildCardBndrs (GhcPass 'Renamed) (LHsKind (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ PredType -> LHsKind (GhcPass 'Renamed)
type_to_hs_type PredType
ty))
type_to_hs_type :: Type -> LHsType GhcRn
type_to_hs_type :: PredType -> LHsKind (GhcPass 'Renamed)
type_to_hs_type = PprPrec -> LHsKind (GhcPass 'Renamed) -> LHsKind (GhcPass 'Renamed)
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> (PredType -> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> PredType
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> (PredType -> HsType (GhcPass 'Renamed))
-> PredType
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XXType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
PredType -> HsType (GhcPass 'Renamed)
forall pass. XXType pass -> HsType pass
XHsType
derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
derivBindCtxt :: Id -> Class -> [PredType] -> SDoc
derivBindCtxt Id
sel_id Class
clas [PredType]
tys
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When typechecking the code for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
sel_id)
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in a derived instance for"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Class -> [PredType] -> SDoc
pprClassPred Class
clas [PredType]
tys) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon)
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"To see the code I am typechecking, use -ddump-deriv" ]
warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcRn ()
warnUnsatisfiedMinimalDefinition ClassMinimalDef
mindef
= do { warn <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingMethods
; let msg = ClassMinimalDef -> TcRnMessage
TcRnUnsatisfiedMinimalDef ClassMinimalDef
mindef
; diagnosticTc warn msg
}
tcSpecInstPrags :: DFunId -> InstBindings GhcRn
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags :: Id
-> InstBindings (GhcPass 'Renamed)
-> TcM ([LTcSpecPrag], TcPragEnv)
tcSpecInstPrags Id
dfun_id (InstBindings { ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass 'Renamed)
binds, ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig (GhcPass 'Renamed)]
uprags })
= do { spec_inst_prags <- (GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) LTcSpecPrag)
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> TcM [LTcSpecPrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Sig (GhcPass 'Renamed) -> TcM TcSpecPrag)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) LTcSpecPrag
forall t a b.
HasLoc t =>
(a -> TcM b) -> GenLocated t a -> TcM (Located b)
wrapLocM (Id -> Sig (GhcPass 'Renamed) -> TcM TcSpecPrag
tcSpecInst Id
dfun_id)) ([GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> TcM [LTcSpecPrag])
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
-> [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig (GhcPass 'Renamed) -> Bool
GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed)) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSpecInstLSig [LSig (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
uprags
; return (spec_inst_prags, mkPragEnv uprags binds) }
tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
tcSpecInst :: Id -> Sig (GhcPass 'Renamed) -> TcM TcSpecPrag
tcSpecInst Id
dfun_id prag :: Sig (GhcPass 'Renamed)
prag@(SpecInstSig XSpecInstSig (GhcPass 'Renamed)
_ LHsSigType (GhcPass 'Renamed)
hs_ty)
= SDoc -> TcM TcSpecPrag -> TcM TcSpecPrag
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Sig (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
spec_ctxt Sig (GhcPass 'Renamed)
prag) (TcM TcSpecPrag -> TcM TcSpecPrag)
-> TcM TcSpecPrag -> TcM TcSpecPrag
forall a b. (a -> b) -> a -> b
$
do { spec_dfun_ty <- UserTypeCtxt -> LHsSigType (GhcPass 'Renamed) -> TcM PredType
tcHsClsInstType UserTypeCtxt
SpecInstCtxt LHsSigType (GhcPass 'Renamed)
hs_ty
; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
where
spec_ctxt :: a -> SDoc
spec_ctxt a
prag = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the pragma:") Int
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag)
tcSpecInst Id
_ Sig (GhcPass 'Renamed)
_ = String -> TcM TcSpecPrag
forall a. HasCallStack => String -> a
panic String
"tcSpecInst"
instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
instDeclCtxt1 :: LHsSigType (GhcPass 'Renamed) -> SDoc
instDeclCtxt1 LHsSigType (GhcPass 'Renamed)
hs_inst_ty
= SDoc -> SDoc
inst_decl_ctxt (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsSigType (GhcPass 'Renamed) -> LHsKind (GhcPass 'Renamed)
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType (GhcPass 'Renamed)
hs_inst_ty))
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 :: PredType -> SDoc
instDeclCtxt2 PredType
dfun_ty
= SDoc -> SDoc
inst_decl_ctxt (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
head_ty)
where
([Id]
_,[PredType]
_,PredType
head_ty) = PredType -> ([Id], [PredType], PredType)
tcSplitQuantPredTy PredType
dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the instance declaration for")
Int
2 (SDoc -> SDoc
quotes SDoc
doc)